IMPLEMENTATION MODULE CompilerExpr ;

FROM SYSTEM IMPORT BYTE ;
FROM TextBuf IMPORT CharAt ;
FROM Runtime IMPORT LoadBias ;

(* Expression grammar and value construction: ParseExpr's precedence climb,
   atoms/subscripts/fields, calls, constant folding, type checks and the
   scalar/string/set/real operand machinery it shares with assignment and
   I/O. *)

FROM CompilerShared IMPORT AposC, ArrRec, BI_Abs, BI_Arctan, BI_Assign,
                          BI_BlockRead, BI_BlockWrite, BI_Chr, BI_Close,
                          BI_ClrEol, BI_ClrScr, BI_Concat, BI_Copy, BI_Cos,
                          BI_Delay, BI_Delete, BI_Dispose, BI_Eof, BI_Erase,
                          BI_Exp, BI_FilePos, BI_FileSize, BI_FillChar,
                          BI_GetDir, BI_GotoXY, BI_Halt, BI_Insert, BI_Int,
                          BI_Intr, BI_IoResult, BI_KeyPressed, BI_Length,
                          BI_Ln, BI_LowVideo, BI_Move, BI_Msdos, BI_New,
                          BI_NormVideo, BI_Ofs, BI_Ord, BI_Pos, BI_Pred,
                          BI_Random, BI_Randomize, BI_Read, BI_ReadLn,
                          BI_Rename, BI_Reset, BI_Rewrite, BI_Round, BI_Seek,
                          BI_Seg, BI_Sin, BI_SizeOf, BI_Sqr, BI_Sqrt, BI_Str,
                          BI_Succ, BI_Trunc, BI_UpCase, BI_Val, BI_Write,
                          BI_WriteLn, CodeMax, CrtCaret, CrtClr, CrtDelay,
                          CrtDh, CrtDl, CrtEol, CrtKey, CrtLow, CrtNorm,
                          DataStart, DirRec, ECompOvf, EConstRange, EFileNF,
                          EInclNest, EIoHere, EMemOvf, ENoLib, ENoSemi,
                          EPointExp, ERes, ESimpType, ETypeErr, EUnknown,
                          EntSize, Err, FileVarSize, FldRec, KBuiltin,
                          KConst, KFunc, KLabel, KProc, KType, KVar, MaxArrs,
                          MaxCode, MaxFields, MaxLine, MaxName, MaxPatch,
                          MaxPend, OK, OpAdd, OpDiv, OpMul, OpShl, OpShr,
                          OpSub, PatchRec, PendRec, TArray, TBool, TChar,
                          TEnum, TFile, TNone, TPtr, TReal, TRecord, TScalar,
                          TSet, TString, TText, TU_BlockRead, TU_BlockWrite,
                          TU_CmpStr, TU_Erase, TU_FileAssign, TU_FileClose,
                          TU_FileEof, TU_FilePos, TU_FileRdln, TU_FileRdtok,
                          TU_FileReadln, TU_FileReset, TU_FileRewrite,
                          TU_FileSize, TU_FillChar, TU_GetDir, TU_Halt,
                          TU_HeapNew, TU_InitMem, TU_IntFmt, TU_IntFmtW,
                          TU_IoResult, TU_IoStore, TU_MemCopy, TU_Move,
                          TU_Msdos, TU_ProgEnd, TU_Random, TU_Randomize,
                          TU_RdBool, TU_RdByte, TU_RdChar, TU_RdInt, TU_RdLn,
                          TU_RdStr, TU_RealAbs, TU_RealAdd, TU_RealArctan,
                          TU_RealCmp, TU_RealCos, TU_RealDiv, TU_RealExp,
                          TU_RealFmt, TU_RealFromInt, TU_RealIntFunc,
                          TU_RealLn, TU_RealMul, TU_RealSin, TU_RealSqrt,
                          TU_RealSub, TU_RealToInt, TU_RealVal, TU_RealWrite,
                          TU_Rename, TU_RunErr, TU_Seek, TU_SetCmp,
                          TU_SetCopy, TU_SetOp, TU_SetSingle, TU_StackChk,
                          TU_StrCat, TU_StrCopy, TU_StrDelete, TU_StrFmtW,
                          TU_StrIndex, TU_StrInsert, TU_StrPos, TU_StrStore,
                          TU_ValInt, TU_ValReal, TU_WrBool, TU_WrBoolW,
                          TU_WrChar, TU_WrCharW, TU_WrInl, TU_WrInt,
                          TU_WrIntW, TU_WrLn, TU_WrReal, TU_WrStr, TU_WrStrW,
                          TUntyp, TkAbsolute, TkAnd, TkArray, TkBegin,
                          TkCase, TkConst, TkDiv, TkDo, TkDownto, TkElse,
                          TkEnd, TkExit, TkExternal, TkFile, TkFor,
                          TkForward, TkFunction, TkGoto, TkIf, TkIn, TkLabel,
                          TkMod, TkNil, TkNone, TkNot, TkOf, TkOr, TkOverlay,
                          TkPacked, TkProcedure, TkProgram, TkRecord,
                          TkRepeat, TkSet, TkString, TkText, TkThen, TkTo,
                          TkType, TkUntil, TkVar, TkWhile, TkWith, abortFac,
                          arrTop, arrs, brkN, brkSave, callScratch, caseJmp,
                          caseN, cbuf, codeSz, constBlob, crtAttrOff,
                          curIsFunc, curProc, curStaticOff, dataBase, dataSz,
                          dc, dirs, entRel, enumHi, enumLo, errNum, exitCnt,
                          exitPatch, fields, fldTop, hdrCS, hdrDS, hdrFlag,
                          hdrHeap, hdrMax, imgReady, lblHi, lblJmp, lblLo,
                          locBytes, locFree, loopTy, nPatch, nPend,
                          newArrIdx, parmOff, patches, pc, pend, prologAt,
                          recFldFirst, recFldLast, resultIsReal,
                          resultPtrOff, resultVar, rtSz, srcPos, tmpA, tmpB,
                          txerrPos, varspc, withBoff, withFF, withFL,
                          withIdx, withIsDI, withN, withSlot ;
FROM CompilerEmit IMPORT AddPatch, Ebyte, EmAddAxCx, EmAndAxCx, EmBpDisp,
                          EmBxDisp, EmCall, EmCmpAxCx, EmCmpAxi, EmDecAx,
                          EmIDivAxCx, EmIncAx, EmJcc, EmJmpNear, EmLdBxBx,
                          EmLeaDiBx, EmLoadVarBx, EmMovAh0, EmMovAxCx,
                          EmMovAxDx, EmMovAxSp, EmMovAxi, EmMovBpSp,
                          EmMovBxBp, EmMovChAl, EmMovChImm, EmMovCxSp,
                          EmMovCxi, EmMovDxAx, EmMovDxBp, EmMovDxBx,
                          EmMulAxCx, EmNegAx, EmNotAx, EmOrAxAx, EmOrAxCx,
                          EmPopAx, EmPopBx, EmPopCx, EmPopDx, EmPopSi,
                          EmPushAx, EmPushBx, EmPushCx, EmPushDx, EmRelSetcc,
                          EmSetcc, EmStoreVarBx, EmSubAxCx, EmXchgAxCx,
                          EmXorAl01, EmXorAxAx, Eword, JccShort, JccShortInv,
                          PatchWord, ResolvePatches, SetPatTgt ;
FROM CompilerSource IMPORT CurCh, ExpandIncludes, GetCh, PeekAhead,
                          SetSourcePath, Upper, inclActive, inclEnd, srcLen ;
FROM CompilerUtil IMPORT Alpha, AlphaNum, BitAnd, BitNot, BitOr, CopyStr,
                          Digit, DropB, DropC, DropCh, IsHexCh, NameEq,
                          NumToName, W16 ;
FROM CompilerSymbols IMPORT CopyWord, DupTest, HideLocals, MaxSym, NewSym,
                          SaveWord, Search, SymEntry, lexnest, symTop,
                          symtab, wrd ;
FROM CompilerLex IMPORT DeclaresProc, ExpectDelim, GetWord, HexVal, InitKeys,
                          IsBlank, KwAhead, MatchAssign, MatchDelim,
                          MatchKey, MatchRange, PeekKw, RdConst, RdIntConst,
                          Skip, StrNew, StrPut, WddTok, rdStrX, strCnt,
                          strLen, strOff, strPool, strTop ;
FROM Compiler IMPORT Assignment, BoundsOf, CodeByteAt, CodeBytes, Compile,
                          Compound, DataBase, DataBytes, DefBuiltins,
                          DefConst, DefLabelPart, DefPart, DefType, DefVar,
                          EmAddBxAx, EmAddDiAx, EmAddDiImm, EmAddSp,
                          EmAndAlDl, EmAndAlImm, EmAndClImm, EmCmpAlImm,
                          EmCrtSeq, EmFileIo, EmIncDi, EmIncSi, EmInlineCh,
                          EmInlineCrLf, EmLdAlBx, EmLdAlDi, EmLdAlDiOff,
                          EmLdAlSi, EmLdAxDi, EmLdDiGlob, EmLeaBx, EmLeaDi,
                          EmLeave, EmLoadVar, EmLoadVarInd, EmLoadVarIndSym,
                          EmMovAxDi, EmMovAxDs, EmMovBxAx, EmMovBxDi,
                          EmMovBxi, EmMovClAl, EmMovDiAx, EmMovDlImm,
                          EmPopDi, EmPushBp, EmPushDi, EmPushSi,
                          EmPushSymAddr, EmPushVarAddr, EmRet, EmShlAxCl,
                          EmShlDlCl, EmShrAx1, EmShrAxCl, EmStDiAl,
                          EmStDiAlOff, EmStDiGlob, EmStDiImm, EmStoreInd,
                          EmStoreVar, EmStoreVarIndPrep, EmSubAlImm, EmSubSp,
                          EmXorByteGlob, EmitFrameBase, EmitStaticLink,
                          HeadWord, IfMatchSemi, ImageByteAt, ImageBytes,
                          Inittur, IsOuterLocal, LabelColonAhead,
                          LeaDiSym, LoadSymVar, ParamSlotBytes, ParseType,
                          ProcFunc, SetSource, SlotSize, Statmnt,
                          StoreSymVar, StoreVarIndPrepSym, SymEpi ;

PROCEDURE ParseExpr (VAR r : ERes) ; FORWARD ;
PROCEDURE ParseAdd (VAR r : ERes) ; FORWARD ;
PROCEDURE ParseMul (VAR r : ERes) ; FORWARD ;
PROCEDURE ParseNeg (VAR r : ERes) ; FORWARD ;
PROCEDURE ParseAtom (VAR r : ERes) ; FORWARD ;
PROCEDURE ParseCall (idx : CARDINAL) ; FORWARD ;
PROCEDURE ParseCallArgs (idx : CARDINAL) ; FORWARD ;
PROCEDURE EmCallMost (idx, cleanup : CARDINAL) ; FORWARD ;
PROCEDURE RealBin (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ; FORWARD ;
PROCEDURE RealUnary (ent : CARDINAL ; VAR r : ERes) ; FORWARD ;
PROCEDURE IntToMbf (v : LONGINT ; VAR b : ARRAY OF CHAR) ; FORWARD ;

PROCEDURE VarSize (r : ERes) : CARDINAL ;
(* The width of a kind-1 value.  An element (`b[i]') or a field (`r.f') has a
   size of its own, which is NOT its variable's; when the parser has recorded
   one, it wins.  Otherwise the variable's declared size is the answer. *)
BEGIN
   IF r.sz > 0 THEN
      RETURN r.sz
   END ;
   RETURN symtab [r.idx].size
END VarSize ;

PROCEDURE IsCharArray (r : ERes) : BOOLEAN ;
(* A fixed `array[..] of char', as opposed to a counted STRING. *)
BEGIN
   IF (r.cls # TArray) OR (r.arrIdx = 0) THEN
      RETURN FALSE
   END ;
   RETURN arrs [r.arrIdx - 1].ecls = TChar
END IsCharArray ;

PROCEDURE LoadAtom (VAR r : ERes) ;
(* load value of r into AX (folding constants).

   A string literal is refused here, and this is the single place that has to:
   assignment, IF, WHILE, FOR, REPEAT, CASE, array subscripts and every
   operator all reach their operand through LoadAtom, and none of them can use
   a counted string where a 16-bit word is expected.  Reporting it here rather
   than in the parser means writeln('hi') still works - IoCall handles a
   literal before it ever calls LoadAtom. *)
VAR emsz : CARDINAL ;
BEGIN
   IF (r.kind = 1) AND symtab [r.idx].isPort THEN
      EmLoadVar (FALSE, symtab [tmpA].off, 2) ;
      EmMovDxAx () ;
      Ebyte (0ECH) ;                       (* IN AL,DX *)
      EmMovAh0 () ;
      r.kind := 2 ;
      RETURN
   END ;
   IF r.cls = TString THEN
      Err (ENoLib) ;                    (* string value used as a number *)
      r.kind := 2 ;
      RETURN
   END ;
   IF r.cls = TSet THEN
      (* A set is bytes, not a 16-bit value.  It is legal as the right operand
         of `in' (and later as a whole-value operand of `+'/`*'/'='/assignment),
         all of which handle it BEFORE LoadAtom - but never as a number, which
         would otherwise load its first two bytes as if it were an integer. *)
      Err (ENoLib) ;
      r.kind := 2 ;
      RETURN
   END ;
   IF r.kind = 5 THEN
      (* An element whose address ParseSub computed into DI (LEA DI,[base] /
         ADD DI,AX): a string character, or an array element of one or two
         bytes.  Zeroing AH keeps a one-byte value a clean 16-bit char.  The
         read must happen HERE, before anything else is emitted: the caller
         reaches this immediately after parsing the subscript, or - for a
         binary operator - SaveLeft has already materialised it, so DI is
         still the element's address. *)
      IF VarSize (r) > 2 THEN
         Err (ENoLib) ;                  (* a whole record/array as a value *)
         r.kind := 2 ;
         RETURN
      END ;
      IF VarSize (r) = 2 THEN
         EmLdAxDi ()
      ELSE
         EmLdAlDi () ;
         EmMovAh0 ()
      END ;
      r.kind := 2 ;
      RETURN
   END ;
   IF r.kind = 0 THEN
      EmMovAxi (W16 (r.imm)) ;
      r.kind := 2
   ELSIF r.kind = 1 THEN
      IF symtab [r.idx].isVar THEN
         (* A VAR parameter: [BP+off] holds the address, and the value is one
            level down.  r.boff is necessarily 0 - a by-reference parameter is
            a scalar in this increment, so it has nothing to subscript. *)
         IF r.boff # 0 THEN
            Err (ENoLib) ;
            r.kind := 2 ;
            RETURN
         END ;
         EmLoadVarIndSym (r.idx, VarSize (r)) ;
         r.kind := 2 ;
         RETURN
      END ;
      IF (VarSize (r) > 2) AND NOT
         ((r.cls = TChar) AND (symtab [r.idx].cls = TString)) THEN
         Err (ENoLib)
      ELSE
         (* s[i] indexes one byte of a string, not the string, so its width is
            one whatever the variable's declared width is. *)
         emsz := VarSize (r) ;
         IF (r.cls = TChar) AND (symtab [r.idx].cls = TString) THEN
            emsz := 1
         END ;
         LoadSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, emsz) ;
         IF emsz = 1 THEN
            EmMovAh0 ()
         END ;
         r.kind := 2
      END
   END
END LoadAtom ;

PROCEDURE EmitBoundsCheck (lo, hi, code : CARDINAL) ;
(* `{$R+}' test: AX must be in [lo,hi].  The error path exits through
   runtime_error; the normal path jumps over the error stub. *)
VAR jl, jg, over : CARDINAL ;
BEGIN
   IF NOT dirs.rng THEN RETURN END ;
   IF lo = hi THEN RETURN END ;
   EmCmpAxi (W16 (lo)) ; jl := EmJcc (8CH, 0) ;
   EmCmpAxi (W16 (hi)) ; jg := EmJcc (8FH, 0) ;
   over := EmJmpNear (0) ;
   SetPatTgt (jl, pc) ; SetPatTgt (jg, pc) ;
   EmMovAxi (code) ; DropC (EmCall (TU_RunErr)) ;
   SetPatTgt (over, pc)
END EmitBoundsCheck ;

PROCEDURE ParseSub (VAR r : ERes) ;
(* consume '[' expr ']' while present.

   A CONSTANT index folds into the base offset boff, exactly as before.  A
   VARIABLE index on a STRING cannot fold - off+i is a run-time value - so it
   is computed once here into DI and r.kind drops to 5, which is how LoadAtom,
   Assignment and IoCall are told the element's address is in DI.  Arrays
   still accept only a constant index: a variable array subscript needs the
   element-size scaling that a one-byte string element does not, and it is
   item 2. *)
VAR t : ERes ;
    ai, fi, nd, k, st, p : CARDINAL ;
    coff : LONGINT ;
    accOnStack, haveVar, more : BOOLEAN ;
    baseDI, found : BOOLEAN ;
BEGIN
   LOOP
      Skip () ;
      IF ((r.cls = TPtr) OR ((r.kind = 1) AND (symtab [r.idx].cls = TPtr)))
         AND (CurCh () = '^') THEN
         (* Dereference after a variable, a field or an array element.  The
            pointer word may be an ordinary symbol (kind 1) or the element
            address already in DI (kind 5, e.g. Friend[Index]^). *)
         DropCh (GetCh ()) ;
         p := r.ptrElem ;
         IF p = 0 THEN
            p := symtab [r.idx].elem
         END ;
         IF r.kind = 5 THEN
            EmLdAxDi () ;
         ELSE
            LoadSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, 2)
         END ;
         EmMovDiAx () ;
         r.idx := p ;
         r.kind := 5 ;
         r.boff := 0 ;
         r.cls := symtab [p].cls ;
         r.sz := symtab [p].size ;
         r.fldFirst := symtab [p].fldFirst ;
         r.fldLast := symtab [p].fldLast ;
         r.arrIdx := symtab [p].arrIdx ;
         r.ptrElem := symtab [p].elem ;
         r.hasBounds := ((symtab [p].cls = TScalar) OR (symtab [p].cls = TEnum)
                         OR (symtab [p].cls = TChar)) AND
                        (symtab [p].lo # symtab [p].hi) ;
         r.blo := symtab [p].lo ; r.bhi := symtab [p].hi
      ELSIF CurCh () = '.' THEN
         (* FIELD selection: `r.f'.  The field's offset adds to the record
            base's, and the value's class and WIDTH become the field's - which
            is the whole reason a width rides on the expression (VarSize). *)
         DropCh (GetCh ()) ;
         Skip () ;
         IF NOT Alpha (CurCh ()) THEN
            Err (EUnknown) ;
            RETURN
         END ;
         GetWord () ;
         IF r.fldFirst >= r.fldLast THEN
            Err (ESimpType) ;               (* not a record *)
            RETURN
         END ;
         fi := r.fldFirst ;
         found := FALSE ;
         WHILE (fi < r.fldLast) AND NOT found DO
            IF NameEq (fields [fi].name, wrd) THEN
               found := TRUE
            ELSE
               INC (fi)
            END
         END ;
         IF NOT found THEN
            Err (EUnknown) ;
            RETURN
         END ;
         IF r.kind = 5 THEN
            (* The element's address is in DI: a field is a fixed offset from
               it.  The array symbol already carries the element record's
               field range (DefVar copies recFldFirst/recFldLast), which is
               why the lookup above works for `Sheet[I,J].Field' too. *)
            IF fields [fi].off # 0 THEN
               EmAddDiImm (fields [fi].off)
            END
         ELSE
            r.boff := W16 (VAL (LONGINT, r.boff)
                           + VAL (LONGINT, fields [fi].off)) ;
         END ;
         r.cls := fields [fi].cls ;
         r.sz := fields [fi].size ;
         r.fldFirst := fields [fi].fldFirst ;
         r.fldLast := fields [fi].fldLast ;
         r.arrIdx := fields [fi].arrIdx ;
         r.ptrElem := fields [fi].ptrElem ;
         r.hasBounds := ((fields [fi].cls = TScalar) OR (fields [fi].cls = TEnum)
                         OR (fields [fi].cls = TChar)) AND
                        (fields [fi].lo # fields [fi].hi) ;
         r.blo := fields [fi].lo ; r.bhi := fields [fi].hi ;
         IF r.cls = TSet THEN
            (* ParseVar set setoff only when the SYMBOL itself was a set; for
               an array/record the class was still TArray/TRecord then, so the
               base offset has to be recorded now. *)
            r.setoff := symtab [r.idx].off ;
            r.setbase := fields [fi].elem ;
            r.setsize := fields [fi].size
         END
      ELSIF CurCh () = '[' THEN
         DropCh (GetCh ()) ;
         IF r.cls = TString THEN
            (* s[i]: a STRING is a length byte at s[0] followed by the
               characters, so index i selects the one byte at off+i.  A second
               subscript on a character is not a type. *)
            ParseExpr (t) ;
            IF OK () THEN
               IF r.cls = TChar THEN
                  Err (ESimpType) ;
                  RETURN
               END ;
               IF symtab [r.idx].isVar THEN
                  (* VAR string parameter: the base is the address in the
                     parameter slot, not LEA of the slot.  Compute DI once for
                     both constant and variable indices, so LoadAtom and
                     Assignment see the same kind-5 character address they do
                     for an ordinary string. *)
                  LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
                  EmMovDiAx () ;
                  IF t.kind = 0 THEN
                     EmAddDiImm ((r.boff + W16 (t.imm)) MOD 10000H)
                  ELSE
                     IF r.boff # 0 THEN
                        EmAddDiImm (r.boff)
                     END ;
                     LoadAtom (t) ;
                     EmAddDiAx ()
                  END ;
                  r.kind := 5
               ELSIF t.kind = 0 THEN
                  (* constant index: fold it into boff, as an array's does, and
                     r.cls drops to TChar so every consumer below - LoadAtom,
                     Assignment, IoCall - sees a one-byte value instead of the
                     whole string. *)
                  IF dirs.rng AND ((t.imm < 1) OR (t.imm > VAL (LONGINT, VarSize (r) - 1))) THEN
                     Err (EConstRange) ; RETURN
                  END ;
                  r.boff := W16 (VAL (LONGINT, r.boff) + t.imm)
               ELSE
                  (* Variable index.  Compute the element address once, now:
                     the index is evaluated into AX (LoadAtom is a no-op for a
                     kind-2 value and re-reads [DI] for a nested subscript), then
                     DI := base + AX.  This is TP3's indstr/ialoop shape (TPSRC9
                     1100-1111, 1200-1229), which likewise holds the address in
                     DI until the byte is loaded or stored; a register is what
                     lets a later LoadAtom read [DI] and a later assignment PUSH
                     DI across its right-hand side. *)
                  LoadAtom (t) ;
                  IF dirs.rng THEN
                     EmPushAx () ;
                     IF symtab [r.idx].isVar THEN
                        LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
                        EmPushAx ()
                     ELSE
                        EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
                     END ;
                     DropC (EmCall (TU_StrIndex)) ;
                     EmAddSp (4)
                  END ;
                  LeaDiSym (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
                  EmAddDiAx () ;
                  r.kind := 5
               END ;
               r.cls := TChar ;
               r.sz := 1
            END ;
            ExpectDelim (']', ENoSemi)
         ELSIF r.arrIdx > 0 THEN
            (* An array subscript LIST: one expression per dimension, comma
               separated.  The byte offset is
                  sum over k of (i[k] - lo[k]) * stride[k]
               where stride[k] is the element size times the count of every
               LATER dimension (row-major: the LAST dimension varies fastest).
               A constant index folds into coff; a run-time one is scaled as
               soon as it is parsed and summed on the STACK, because parsing
               the next index may clobber AX and DI. *)
            baseDI := (r.kind = 5) ;
            ai := r.arrIdx - 1 ;
            nd := 0 ;
            coff := 0 ;
            accOnStack := FALSE ;
            haveVar := FALSE ;
            LOOP
               IF nd >= arrs [ai].n THEN
                  Err (ETypeErr) ;
                  RETURN
               END ;
               ParseExpr (t) ;
               IF NOT OK () THEN
                  RETURN
               END ;
               Skip () ;
               IF CurCh () = ':' THEN
                  (* TP3 segment:offset form in Mem[...]; the segment
                     expression is consumed and the offset is the index. *)
                  DropCh (GetCh ()) ;
                  ParseExpr (t) ;
                  IF NOT OK () THEN
                     RETURN
                  END
               END ;
               st := arrs [ai].elem ;
               k := nd + 1 ;
               WHILE k < arrs [ai].n DO
                  st := st * W16 (arrs [ai].hi [k] - arrs [ai].lo [k] + 1) ;
                  INC (k)
               END ;
               Skip () ;
               more := CurCh () = ',' ;
               IF t.kind = 0 THEN
                  IF dirs.rng AND ((t.imm < arrs [ai].lo [nd]) OR
                                   (t.imm > arrs [ai].hi [nd])) THEN
                     Err (EConstRange) ; RETURN
                  END ;
                  coff := coff + (t.imm - arrs [ai].lo [nd])
                                 * VAL (LONGINT, st)
               ELSE
                  LoadAtom (t) ;
                  EmitBoundsCheck (arrs [ai].lo [nd], arrs [ai].hi [nd], 16) ;
                  IF arrs [ai].lo [nd] # 0 THEN
                     EmMovCxi (W16 (arrs [ai].lo [nd])) ;
                     EmSubAxCx ()
                  END ;
                  IF st # 1 THEN
                     EmMovCxi (st) ;
                     EmMulAxCx ()
                  END ;
                  IF more THEN
                     (* the next dimension's expression will clobber AX: park
                        the running sum.  A SINGLE index skips this entirely,
                        so 1-D code is byte-identical to the old path. *)
                     IF accOnStack THEN
                        EmPopCx () ;
                        EmAddAxCx () ;
                        EmPushAx ()
                     ELSE
                        EmPushAx () ;
                        accOnStack := TRUE
                     END
                  ELSE
                     (* last dimension: AX is the total *)
                     IF accOnStack THEN
                        EmPopCx () ;
                        EmAddAxCx () ;
                        accOnStack := FALSE
                     END ;
                     haveVar := TRUE
                  END
               END ;
               INC (nd) ;
               IF more THEN
                  DropCh (GetCh ())
               ELSE
                  EXIT
               END
            END ;
            IF nd # arrs [ai].n THEN
               (* fewer subscripts than dimensions: the value would be a
                  sub-array, which has no scalar representation *)
               Err (ETypeErr) ;
               RETURN
            END ;
            ExpectDelim (']', ENoSemi) ;
            IF accOnStack THEN
               (* the last dimensions were constant: the parked sum is still
                  on the stack, and AX is the total *)
               EmPopAx () ;
               accOnStack := FALSE
            END ;
            IF baseDI THEN
               (* The base address is already in DI: a pointer dereference
                  (`Buffer^[i]').  Add the computed byte offset to it; a
                  constant-only index can use ADD DI,imm16. *)
               IF haveVar THEN
                  EmAddDiAx ()
               ELSE
                  IF coff # 0 THEN
                     EmAddDiImm (W16 (coff))
                  END
               END ;
               r.kind := 5
            ELSIF haveVar THEN
               LeaDiSym (r.idx, (symtab [r.idx].off + r.boff
                         + W16 (coff)) MOD 10000H) ;
               EmAddDiAx () ;
               r.kind := 5
            ELSE
               r.boff := W16 (VAL (LONGINT, r.boff) + coff)
            END ;
            r.sz := arrs [ai].elem ;
            r.cls := arrs [ai].ecls ;
            r.fldFirst := arrs [ai].fldFirst ;
            r.fldLast := arrs [ai].fldLast ;
            r.arrIdx := 0 ;
            r.ptrElem := arrs [ai].elemType ;
            r.hasBounds := ((arrs [ai].ecls = TScalar) OR (arrs [ai].ecls = TEnum)
                             OR (arrs [ai].ecls = TChar)) AND
                            (arrs [ai].elemLo # arrs [ai].elemHi) ;
            r.blo := arrs [ai].elemLo ; r.bhi := arrs [ai].elemHi
         ELSE
            ParseExpr (t) ;
            IF OK () THEN
               IF t.kind # 0 THEN
                  Err (ENoLib)
               ELSE
                  Err (ESimpType)
               END
            END ;
            ExpectDelim (']', ENoSemi)
         END
      ELSE
         RETURN
      END
   END
END ParseSub ;

PROCEDURE ParseVar (VAR r : ERes) ;
(* name [ '[' constExpr ']' ]* ; a function name maps to its result var *)
VAR idx, p : CARDINAL ;
    t : ERes ;
BEGIN
   IF NOT Search (wrd, idx) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   IF symtab [idx].isPort THEN
      (* TP3's Port[address]: a byte-wide pseudo-array implemented with IN/OUT.
         The index is evaluated once into the compiler scratch word; assignment
         and LoadAtom turn it into OUT DX,AL / IN AL,DX. *)
      Skip () ;
      IF CurCh () # '[' THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      DropCh (GetCh ()) ;
      ParseExpr (t) ;
      IF NOT OK () THEN RETURN END ;
      IF (t.cls # TScalar) AND (t.cls # TChar) THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      LoadAtom (t) ;
      EmStoreVar (FALSE, symtab [tmpA].off, 2) ;
      ExpectDelim (']', ENoSemi) ;
      r.kind := 1 ;
      r.idx := idx ;
      r.cls := TScalar ;
      r.sz := 1 ;
      r.boff := 0 ;
      r.hasBounds := FALSE ;
      RETURN
   END ;
   IF symtab [idx].cls = TPtr THEN
      Skip () ;
      IF CurCh () = '^' THEN
         (* Dereference: the pointer word is the base address.  r.idx becomes
            the pointee TYPE symbol, because ParseSub reads an array/record's
            metadata from the symbol, not from the expression. *)
         DropCh (GetCh ()) ;
         p := symtab [idx].elem ;
         LoadSymVar (idx, symtab [idx].off, 2) ;
         EmMovDiAx () ;
         r.idx := p ;
         r.kind := 5 ;
         r.boff := 0 ;
         r.cls := symtab [p].cls ;
         r.sz := symtab [p].size ;
         r.fldFirst := symtab [p].fldFirst ;
         r.fldLast := symtab [p].fldLast ;
         r.arrIdx := symtab [p].arrIdx ;
         r.ptrElem := symtab [p].elem ;
         r.hasBounds := ((symtab [p].cls = TScalar) OR (symtab [p].cls = TEnum)
                         OR (symtab [p].cls = TChar)) AND
                        (symtab [p].lo # symtab [p].hi) ;
         r.blo := symtab [p].lo ; r.bhi := symtab [p].hi ;
         ParseSub (r) ;
         RETURN
      END
   END ;
   r.idx := idx ;
   r.kind := 1 ;
   r.boff := 0 ;
   r.cls := symtab [idx].cls ;
   IF symtab [idx].tag = KFunc THEN
      idx := symtab [idx].resvar ;
      r.idx := idx ;
      r.cls := symtab [idx].cls
   ELSIF (symtab [idx].tag # KVar) AND (symtab [idx].tag # KType) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   IF r.cls = TSet THEN
      (* a set value: carry where its bytes are so ParseCmp can fold `in' and
         (later) compare.  A set VARIABLE is still refused at its declaration,
         so today this is a typed constant or an inline literal. *)
      r.setoff := symtab [r.idx].off ;
      r.setbase := symtab [r.idx].elem ;
      r.setsize := symtab [r.idx].size
   END ;
   r.sz := symtab [r.idx].size ;
   r.fldFirst := symtab [r.idx].fldFirst ;
   r.fldLast := symtab [r.idx].fldLast ;
   r.arrIdx := symtab [r.idx].arrIdx ;
   r.ptrElem := symtab [r.idx].elem ;
   r.hasBounds := ((symtab [r.idx].cls = TScalar) OR (symtab [r.idx].cls = TEnum)
                   OR (symtab [r.idx].cls = TChar)) AND
                  (symtab [r.idx].lo # symtab [r.idx].hi) ;
   r.blo := symtab [r.idx].lo ; r.bhi := symtab [r.idx].hi ;
   ParseSub (r)
END ParseVar ;

PROCEDURE ConstAdd (a, b : LONGINT) : LONGINT ;
BEGIN
   RETURN VAL (LONGINT, W16 (a + b))
END ConstAdd ;

PROCEDURE ConstSub (a, b : LONGINT) : LONGINT ;
BEGIN
   RETURN VAL (LONGINT, W16 (a - b))
END ConstSub ;

PROCEDURE ConstMul (a, b : LONGINT) : LONGINT ;
BEGIN
   RETURN VAL (LONGINT, W16 (a * b))
END ConstMul ;

PROCEDURE EmXchgAxDx () ;
(* 92h = XCHG AX,DX.  Named for what it EMITS, which is the point of the
   whole naming convention: this used to be called EmMoveAxDx, which is what
   somebody would expect the opcode to be, and it is not - 89 D8 is
   MOV AX,DX, 92h is the exchange.  Here the exchange is what is wanted, so
   the name is the only thing that was wrong, and it was wrong in the exact
   way this file's names are not allowed to be: reading as "a move" when it
   is a swap.  After EmIDivAxCx the remainder is in DX and `mod` wants it in
   AX; an exchange gets it there in one byte where a move also would, so the
   behaviour is identical either way and only the name lied. *)
BEGIN
   Ebyte (92H)
END EmXchgAxDx ;

PROCEDURE StrConcat (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ; FORWARD ;
PROCEDURE StrOperand (r : ERes) : BOOLEAN ; FORWARD ;

PROCEDURE BinOpEmit (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ;
(* binary operation at one precedence level; folds constant operands *)
VAR f : LONGINT ;
    okc : BOOLEAN ;
BEGIN
   IF (left.cls = TReal) OR (right.cls = TReal) OR (op = OpDiv) THEN
      (* `/` is real division even when both operands are integers; Pascal's
         `div` is the integer operator and has its own token. *)
      RealBin (op, left, right, res) ;
      RETURN
   END ;
   IF StrOperand (left) OR StrOperand (right) THEN
      (* A string OPERAND - a STRING or a CHAR, which is a one-character string
         for this purpose - makes this a string operation, and `+' is the only
         one ISO Modula-2 defines: every other binary operator reached here
         (OR, and the multiplicative and additive numeric ops) has no meaning
         over a STRING, and StrConcat rejects it.

         The test is StrOperand and NOT `cls = TString' because of the two
         CHAR operands.  `'a' + 'b'' has no STRING in it at all, so a
         TString-only test let it fall through to the integer path, where the
         character codes were added and CHR(195) was printed - a silently
         wrong program rather than an error (see t53_strcat_type).  A CHAR
         operand is still a string operand, which is also what makes `a + ch'
         concatenate.

         Handling it here, at the head of the one routine every binary
         operator funnels through, is what keeps `a + b', `writeln(a + b)',
         `(a + b) = c' and `s := a + b + c' all going through the same
         emission. *)
      StrConcat (op, left, right, res) ;
      RETURN
   END ;
   IF op = TkAnd THEN
      IF (left.kind = 0) AND (right.kind = 0) THEN
         res.kind := 0 ;
          res.imm := BitAnd (left.imm, right.imm) ;
         IF (left.cls = TBool) OR (right.cls = TBool) THEN
            res.cls := TBool
         ELSE
            res.cls := left.cls
         END ;
         RETURN
      END ;
      LoadPair (left, right) ;
      EmAndAxCx () ;
      res.kind := 2 ;
      IF (left.cls = TBool) OR (right.cls = TBool) THEN
         res.cls := TBool
      ELSE
         res.cls := left.cls
      END ;
      RETURN
   END ;
   IF op = TkOr THEN
      IF (left.kind = 0) AND (right.kind = 0) THEN
         res.kind := 0 ;
         res.imm := BitOr (left.imm, right.imm) ;
         IF (left.cls = TBool) OR (right.cls = TBool) THEN
            res.cls := TBool
         ELSE
            res.cls := left.cls
         END ;
         RETURN
      END ;
      LoadPair (left, right) ;
      EmOrAxCx () ;
      res.kind := 2 ;
      IF (left.cls = TBool) OR (right.cls = TBool) THEN
         res.cls := TBool
      ELSE
         res.cls := left.cls
      END ;
      RETURN
   END ;
   IF (left.kind = 0) AND (right.kind = 0) THEN
      okc := FALSE ;
      CASE op OF
         OpAdd : f := ConstAdd (left.imm, right.imm) ; okc := TRUE ;
      |  OpSub : f := ConstSub (left.imm, right.imm) ; okc := TRUE ;
      |  OpMul : f := ConstMul (left.imm, right.imm) ; okc := TRUE ;
      |  TkDiv : okc := (right.imm # 0) AND (right.imm > 0)
                        AND (left.imm >= 0) ;
                 IF okc THEN f := left.imm DIV right.imm END ;
      |  TkMod : okc := (right.imm # 0) AND (right.imm > 0)
                        AND (left.imm >= 0) ;
                 IF okc THEN f := left.imm MOD right.imm END ;
      ELSE
         okc := FALSE
      END ;
      IF okc THEN
         res.kind := 0 ;
         res.imm := VAL (LONGINT, W16 (f)) ;
         res.cls := left.cls ;
         RETURN
      ELSIF op = TkDiv THEN
         Err (EConstRange) ;
         RETURN
      END
   END ;
   LoadPair (left, right) ;
   CASE op OF
      OpAdd : EmAddAxCx ;
   |  OpSub : EmSubAxCx ;
   |  OpMul : EmMulAxCx ;
   |  OpShl : EmShlAxCl ;
   |  OpShr : EmShrAxCl ;
   |  TkDiv : EmIDivAxCx ;
   |  TkMod : EmIDivAxCx ; EmXchgAxDx ;
   ELSE
      Err (ETypeErr)
   END ;
   res.kind := 2 ;
   res.cls := left.cls
END BinOpEmit ;

PROCEDURE ConstCmp (op : CARDINAL ; a, b : LONGINT ; VAR f : LONGINT)
         : BOOLEAN ;
VAR a16, b16 : CARDINAL ;
BEGIN
   a16 := W16 (a) ;
   b16 := W16 (b) ;
   f := 0 ;
   CASE op OF
      1 : f := VAL (LONGINT, ORD (a16 = b16)) ;
   |  2 : f := VAL (LONGINT, ORD (a16 # b16)) ;
   |  3 : f := VAL (LONGINT, ORD (a16 < b16)) ;
   |  4 : f := VAL (LONGINT, ORD (a16 >= b16)) ;
   |  5 : f := VAL (LONGINT, ORD (a16 > b16)) ;
   |  6 : f := VAL (LONGINT, ORD (a16 <= b16)) ;
   ELSE
      RETURN FALSE
   END ;
   RETURN TRUE
END ConstCmp ;

(* ---------------------------------------------------------------- *)
(*  keeping an operand alive across the parse of the other one       *)
(* ---------------------------------------------------------------- *)

PROCEDURE SaveLeft (VAR left : ERes) ;
VAR sk : CARDINAL ;
(* Called the moment the operator has been recognised, i.e. *before* the
   right-hand operand is parsed.

   Every binary level in this parser has the shape

      left := r ; ParseXxx (right) ; BinOpEmit (op, left, right, r) ;

   so the right-hand operand's code is emitted between those two lines, and
   the left-hand operand has to survive that.  For kind 0 (a constant) and
   kind 1 (a named variable) there is nothing to survive: LoadAtom re-emits
   the MOV or the load at the operator site, and no code has been emitted
   for the left yet.  A kind-2 value is different - its code is already in
   the image and its value exists only in AX, which the right-hand parse is
   about to overwrite.  The value had to be parked on the stack instead.

   TPSRC9 does exactly this in the other order: addptr and mulptr CALL
   pushres (which calls loadatom and sets flgpshax) *before* CALL mullevel,
   so PUSH AX lands in the image ahead of the right-hand operand's code.
   Without this, `(p > q) or (q > p)` emitted both comparisons and then
   ORed the *second* comparison's result with itself - which is why it
   printed FALSE for TRUE or FALSE. *)
BEGIN
   IF left.cls = TReal THEN
      (* Park six bytes in a fresh scratch, exactly as kind-5 does for a
         scalar: the right-hand parse may reuse DI or call a routine. *)
      sk := NewScratchReal () ;
      EmCopyRealTo (symtab [sk].off, left) ;
      left.idx := sk ;
      left.kind := 1 ;
      left.cls := TReal ;
      left.sz := 6 ;
      left.boff := 0
   ELSIF left.kind = 2 THEN
      EmPushAx () ;
      left.kind := 4                      (* 4 = on the top of the stack *)
   ELSIF left.kind = 5 THEN
      (* A string element whose address is in DI.  This is the one place the
         address must be spent BEFORE the right-hand operand is parsed: DI
         cannot survive it, because the right operand may hold a subscript of
         its own (which reuses DI) or call a routine (which may clobber it).
         Reading [DI] now - which LoadAtom does, turning kind 5 into kind 2 -
         and pushing the value is exactly what the kind-2 case above does
         next, so the two branches converge on kind 4.  A subscript on the
         RIGHT is fine: it sets DI after this point and LoadPair reads it
         immediately, with no parse in between. *)
      LoadAtom (left) ;                   (* AL := [DI], AH := 0; kind := 2 *)
      EmPushAx () ;
      left.kind := 4
   END
END SaveLeft ;

PROCEDURE LoadPair (VAR left, right : ERes) ;
(* Materialise both operands of a binary operator so that, once this
   returns, AX holds the LEFT one and CX the RIGHT one - which is the state
   EmAddAxCx/EmSubAxCx/EmMulAxCx/EmIDivAxCx/EmAndAxCx/EmOrAxCx/EmCmpAxCx
   all expect (see EmXchgAxCx).

   Three shapes, and only three:

     left.kind = 4   SaveLeft pushed it before the right operand was
                     parsed, so the right value is in AX and the left one
                     is on the stack: load the right (a no-op for kind 2),
                     pop the left into CX, then swap.
     right.kind = 2  The right value is in AX, and loading the left would
                     destroy it: push the right, load the left, then pop
                     the right straight into CX.  No swap needed.
     neither         Both can still be materialised from scratch, and
                     neither is at risk, so this is the original sequence.

   A kind-5 right-hand operand takes that last shape, and is safe there: the
   only instruction emitted before its LoadAtom is the left's, and MOV AX,[var]
   and MOV AX,imm do not touch DI, so [DI] still holds the element address.

   Whichever shape is taken, exactly one push is matched by exactly one
   pop. *)
BEGIN
   IF left.kind = 4 THEN
      LoadAtom (right) ;
      EmPopCx () ;
      EmXchgAxCx ()
   ELSIF right.kind = 2 THEN
      EmPushAx () ;
      LoadAtom (left) ;
      EmPopCx ()
   ELSE
      LoadAtom (left) ; EmPushAx () ;
      LoadAtom (right) ; EmPopCx () ;
      EmXchgAxCx ()
   END
END LoadPair ;

PROCEDURE EmStrBlob (r : ERes) : CARDINAL ;
(* Emit a string literal's <len><chars> in the code stream behind a JMP and
   return the image offset of the LENGTH byte.  Shared by EmPushStrAddr (which
   pushes that address) and EmPushStrSlot (which copies the bytes onto the
   stack for a string value parameter). *)
VAR n, len, here : CARDINAL ;
BEGIN
   len := strLen [r.strx] ;
   IF len > 255 THEN
      (* As in IoCall: the length is one byte, so a longer literal would wrap
         and silently carry only its first (length MOD 256) characters.
         TP3 strings are at most 255 characters. *)
      Err (EConstRange) ;
      RETURN 0
   END ;
   IF len + 1 <= 127 THEN
      Ebyte (0EBH) ; Ebyte (VAL (BYTE, len + 1))    (* JMP rel8 over it *)
   ELSE
      Ebyte (0E9H) ; Eword (len + 1)                (* JMP rel16 over it *)
   END ;
   here := pc ;                 (* the length byte: the literal's address *)
   Ebyte (VAL (BYTE, len)) ;
   n := 0 ;
   WHILE n < len DO
      Ebyte (VAL (BYTE, ORD (strPool [strOff [r.strx] + n]))) ;
      INC (n)
   END ;
   RETURN here
END EmStrBlob ;

PROCEDURE EmAsciiZLiteral (start, stop : CARDINAL) : CARDINAL ;
(* Emit the source text [start,stop) as a NUL-terminated code-resident string
   behind a JMP and return its image offset.  Used for REAL literals, which are
   parsed by the runtime's ascreal rather than by a host-side decimal parser. *)
VAR here, n, len : CARDINAL ;
BEGIN
   len := stop - start ;
   IF len <= 126 THEN
      Ebyte (0EBH) ; Ebyte (VAL (BYTE, len + 1))
   ELSE
      Ebyte (0E9H) ; Eword (len + 1)
   END ;
   here := pc ;
   n := start ;
   WHILE n < stop DO
      Ebyte (VAL (BYTE, ORD (CharAt (n)))) ;
      INC (n)
   END ;
   Ebyte (0) ;
   RETURN here
END EmAsciiZLiteral ;

PROCEDURE EmPushSetAddr (r : ERes) ;
(* Push the ADDRESS of a set value: the runtime's set entries take addresses.
   A set literal/typed constant is code-resident (kind 7), a set-expression
   result is a data buffer (kind 8), a named set is symbol+boff, and a field
   reached through DI is already addressed. *)
BEGIN
   IF r.kind = 5 THEN
      EmPushDi ()
   ELSIF r.kind = 1 THEN
      EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
   ELSIF (r.kind = 7) OR (r.kind = 8) THEN
      EmPushVarAddr (FALSE, r.setoff)
   ELSE
      Err (ENoLib)
   END
END EmPushSetAddr ;

PROCEDURE SetPairSize (left, right : ERes ; VAR size, base : CARDINAL) : BOOLEAN ;
(* The byte count for a set operation.  An inline literal is a 32-byte
   `set of Char' by default; when the other operand is a typed set (CALC's
   one-byte `set of Attributes') that type wins.  Two non-literals must have
   the same origin and are taken at the smaller size; the runtime only ever
   touches that many bytes. *)
BEGIN
   IF left.setbase # right.setbase THEN
      RETURN FALSE
   END ;
   base := left.setbase ;
   IF left.kind = 7 THEN
      IF right.kind = 7 THEN
         size := left.setsize
      ELSE
         size := right.setsize
      END
   ELSIF right.kind = 7 THEN
      size := left.setsize
   ELSE
      size := left.setsize ;
      IF right.setsize < size THEN
         size := right.setsize
      END
   END ;
   RETURN (size > 0) AND (size <= 32)
END SetPairSize ;

PROCEDURE AllocSetScratch (size : CARDINAL) : CARDINAL ;
(* A fresh data buffer for one set expression.  One per operation, so a nested
   or repeated expression cannot overwrite the other side while it is still
   being consumed.  The bytes need no initialisation: every operation writes
   all `size' of them before the value is read. *)
VAR off : CARDINAL ;
BEGIN
   IF dc + size > 0F000H THEN
      Err (EConstRange) ;
      RETURN 0
   END ;
   off := dc ;
   dc := dc + size ;
   RETURN off
END AllocSetScratch ;

PROCEDURE SetBinEmit (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ;
(* The caller has already pushed the LEFT address (before parsing the right
   operand, so a DI-addressed field survives).  Finish the argument list -
   right, destination, (op<<8)|size - call the runtime, and return the buffer
   as a kind-8 set value. *)
VAR size, base, dest : CARDINAL ;
BEGIN
   IF NOT SetPairSize (left, right, size, base) THEN
      Err (ENoLib) ;
      RETURN
   END ;
   dest := AllocSetScratch (size) ;
   IF NOT OK () THEN
      RETURN
   END ;
   EmPushSetAddr (right) ;
   EmPushVarAddr (FALSE, dest) ;
   EmMovAxi (W16 (op * 256 + size)) ;
   EmPushAx () ;
   DropC (EmCall (TU_SetOp)) ;
   EmAddSp (8) ;
   res.kind := 8 ;
   res.cls := TSet ;
   res.chr := FALSE ;
   res.setoff := dest ;
   res.setbase := base ;
   res.setsize := size
END SetBinEmit ;

PROCEDURE MaterializeDyn (VAR r : ERes ; base, size : CARDINAL) ;
(* Build a scratch set of `size' bytes with the single dynamic element at
   `base' set.  Used for TP3's `[Storage[Index]]' constructor. *)
VAR dest : CARDINAL ;
BEGIN
   dest := AllocSetScratch (size) ;
   IF NOT OK () THEN
      RETURN
   END ;
   EmMovAxi (size) ; EmPushAx () ;
   EmMovAxi (base) ; EmPushAx () ;
   LoadSymVar (r.dynElem, symtab [r.dynElem].off, 2) ;
   EmPushAx () ;
   EmPushVarAddr (FALSE, dest) ;
   DropC (EmCall (TU_SetSingle)) ;
   EmAddSp (8) ;
   r.kind := 8 ;
   r.setoff := dest ;
   r.setbase := base ;
   r.setsize := size
END MaterializeDyn ;

PROCEDURE EmPushStrAddr (r : ERes) ;
(* Push the ADDRESS of a whole-string operand - the argument shape cmpstr
   takes, one per operand.

   A string VARIABLE's value already is its address, so this is the same push
   READ makes (EmPushVarAddr), through symtab's local/off.

   A string LITERAL has no storage, and the image carries no initialised data
   to put one in (globals are left to the loader's zero fill), so the
   characters have to travel in the code stream and the operand is the address
   of those bytes.  TP3 does the same in TPSRC9 fullvar (993): it builds the
   `JMP' opcode in AL and the length in AH (`MOV AL,#$EB' / `MOV.B AH,CH'),
   emits that word, and takes the position immediately after it as varofs,
   with varseg := CS - the instruction stream steps over the constant instead
   of running into it.

   The difference is one byte, and it is deliberate.  TP3's constant is an
   ARRAY [1..n] OF CHAR, and `estr2' (TPSRC10 85) emits it WITHOUT a length
   byte because the length travelled on the stack instead.  Every string in
   THIS runtime - variable or literal - is a `string': a length byte and then
   the characters, which is what rdstr writes and what cmpstr reads.  So a
   literal operand has to look the same, and the jump carries one extra byte:
   <len><chars>, with the ADDRESS pushed being the length byte itself.  The
   jump still exists only to keep the CPU from walking into the characters.

   Nothing is added to the data segment and no runtime entry is involved in
   reading the literal; LEA AX,[that] is absolute into the code segment, which
   is where a .COM's DS already is.

   A 1-character literal is NOT a TString here: RdConst reports it as TScalar
   (its character code), so `s = 'a'` compares a string with a character and
   is a type error rather than a length-1 string compare.  That is deliberate
   - it is the same rule `c := 'a'` relies on - and the caller rejects it. *)
BEGIN
   IF r.kind = 5 THEN
      (* a string element/field computed through DI - `Sheet[X,Y].Contents'
         and the `with' form.  DI holds the field's address, which is exactly
         what cmpstr/strcat/strstore take on the stack, so push it.  This used
         to be ENoLib, and it was the CALC rung after Write(Value:FW:DEC):
         `if Sheet[UFX,UFY].Contents <> '' then'. *)
      EmPushDi ()
   ELSIF r.kind = 1 THEN
      IF symtab [r.idx].isVar THEN
         (* A VAR string parameter: the slot at [BP+off] holds the address of
            the caller's characters, so push its CONTENTS, not the address of
            the slot.  boff is zero for the whole string; an element/subscript
            is kind 5 and handled above. *)
         IF r.boff # 0 THEN
            Err (ENoLib)
         ELSE
            LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
            EmPushAx ()
         END
      ELSE
         EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
      END
   ELSIF r.kind = 3 THEN
      EmPushVarAddr (FALSE, EmStrBlob (r))  (* the literal travels inline *)
   ELSE
      Err (ENoLib)                 (* a computed string is not a value *)
   END
END EmPushStrAddr ;

PROCEDURE EmPushRealAddr (r : ERes) ;
(* Push the address of a six-byte REAL actual: ordinary variable, VAR REAL
   parameter (slot holds the address), or a kind-5 field/function result. *)
BEGIN
   IF r.kind = 5 THEN
      EmPushDi ()
   ELSIF r.kind = 1 THEN
      IF symtab [r.idx].isVar THEN
         LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
         EmPushAx ()
      ELSE
         EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
      END
   ELSE
      Err (ENoLib)
   END
END EmPushRealAddr ;

PROCEDURE EmPushRealSlot (r : ERes ; reserve : CARDINAL) ;
(* Push a six-byte value REAL argument's whole slot onto the stack. *)
BEGIN
   EmPushRealAddr (r) ;
   EmPopSi () ;
   EmSubSp (reserve) ;
   Ebyte (89H) ; Ebyte (0E7H) ;       (* MOV DI,SP *)
   EmMovCxi (reserve) ;
   Ebyte (8AH) ; Ebyte (04H) ;        (* MOV AL,[SI] *)
   Ebyte (88H) ; Ebyte (05H) ;        (* MOV [DI],AL *)
   Ebyte (46H) ; Ebyte (47H) ;        (* INC SI / INC DI *)
   Ebyte (0E2H) ; Ebyte (0F8H)        (* LOOP back *)
END EmPushRealSlot ;

PROCEDURE EmCopyRealTo (dstOff : CARDINAL ; r : ERes) ;
(* Copy six REAL bytes from r's address into the image global at dstOff, or
   materialise an integer constant there as MBF. *)
VAR k : CARDINAL ;
    rbuf : ARRAY [0..5] OF CHAR ;
BEGIN
   IF r.cls = TReal THEN
      EmPushRealAddr (r) ;
      EmPopSi () ;
      EmLeaDi (FALSE, dstOff) ;
      EmMovCxi (6) ;
      Ebyte (8AH) ; Ebyte (04H) ;      (* MOV AL,[SI] *)
      Ebyte (88H) ; Ebyte (05H) ;      (* MOV [DI],AL *)
      Ebyte (46H) ; Ebyte (47H) ;
      Ebyte (0E2H) ; Ebyte (0F8H)      (* LOOP -8 *)
   ELSIF (r.cls = TScalar) AND (r.kind = 0) THEN
      IntToMbf (r.imm, rbuf) ;
      k := 0 ;
      WHILE k < 6 DO
         EmMovAxi (ORD (rbuf [k])) ;
         EmStoreVar (FALSE, (dstOff + k) MOD 10000H, 1) ;
         INC (k)
      END
   ELSE
      Err (ENoLib)
   END
END EmCopyRealTo ;

PROCEDURE EmPushStrSlot (r : ERes ; reserve, copyN : CARDINAL) ;
(* Push a STRING VALUE argument's whole slot: reserve `reserve' bytes on the
   stack and copy `copyN' of the source string's <len><chars> into them, so
   that after the CALL the callee's BP+4 is the length byte and the characters
   follow it.

     <push the source address, then POP SI>   ; local/global/literal alike
     SUB SP,reserve ; MOV DI,SP ; MOV CX,copyN
     loop: MOV AL,[SI] ; MOV [DI],AL ; INC SI ; INC DI ; LOOP loop

   The address comes from EmPushStrAddr, which already knows how to form it for
   a local ([BP+off]), a global (absolute) or a literal (inline blob) - so a
   caller's LOCAL string can be passed too, not just a global.

   A byte loop, not REP MOVSB, on purpose: MOVS/STOS address through ES, and a
   .COM's ES happens to equal DS but nothing in this compiler establishes that
   contract.  Every access here is DS-relative, which is the one segment the
   image already guarantees.  `copyN' is at most `reserve' (a shorter actual
   string than the formal leaves the tail of the slot untouched, harmless
   because the length byte bounds every read). *)
BEGIN
   EmPushStrAddr (r) ;                   (* push the source address *)
   EmPopSi () ;                          (* SI := source *)
   EmSubSp (reserve) ;
   Ebyte (89H) ; Ebyte (0E7H) ;          (* MOV DI,SP *)
   EmMovCxi (copyN) ;
   IF copyN > 0 THEN
      Ebyte (8AH) ; Ebyte (04H) ;        (* MOV AL,[SI] *)
      Ebyte (88H) ; Ebyte (05H) ;        (* MOV [DI],AL *)
      Ebyte (46H) ;                      (* INC SI *)
      Ebyte (47H) ;                      (* INC DI *)
      Ebyte (0E2H) ; Ebyte (0F8H)        (* LOOP -8: back to MOV AL,[SI] *)
   END
END EmPushStrSlot ;

(* ---------------------------------------------------------------- *)
(*  sets - type sizing, literals, compile-time membership            *)
(* ---------------------------------------------------------------- *)

PROCEDURE SetRangeBits (VAR bytes : ARRAY OF CHAR ; size, base : CARDINAL ;
                        lo, hi : LONGINT) ;
(* Set the bits for every element in [lo, hi], using TP3's hybrid rule
   (coeur-tp-ocr 4.7.2): element e is bit (e MOD 8) of byte
   ((e DIV 8) - (base DIV 8)), and is IGNORED unless that byte is in
   [0, size).  A value that lands outside the used bytes is truncated away, as
   TP3 does; one inside them but outside the DECLARED range still lands, which
   is also TP3's behaviour. *)
VAR rel, first, last, bidx, bit, m, o : CARDINAL ;
BEGIN
   IF (hi < 0) OR (lo > 255) THEN
      RETURN
   END ;
   IF lo < 0 THEN first := 0 ELSE first := VAL (CARDINAL, lo) END ;
   IF hi > 255 THEN last := 255 ELSE last := VAL (CARDINAL, hi) END ;
   rel := first ;
   WHILE rel <= last DO
      IF rel >= base THEN
         bidx := (rel - base) DIV 8 ;
         IF bidx < size THEN
            bit := (rel - base) MOD 8 ;
            m := 1 ;
            WHILE bit > 0 DO
               m := m * 2 ; DEC (bit)
            END ;
            o := ORD (bytes [bidx]) ;
            IF (o DIV m) MOD 2 = 0 THEN
               bytes [bidx] := CHR (o + m)
            END
         END
      END ;
      INC (rel)
   END
END SetRangeBits ;

PROCEDURE RdSetLiteral (base, size : CARDINAL ; VAR bytes : ARRAY OF CHAR) : BOOLEAN ;
(* Read a set constructor `[e, a..b, ...]' and fill `bytes' (already size
   long).  `[]' is the empty set. *)
VAR v, hi : LONGINT ; subcls : CARDINAL ; strf : BOOLEAN ; k : CARDINAL ;
BEGIN
   k := 0 ;
   WHILE k < size DO
      bytes [k] := CHR (0) ;
      INC (k)
   END ;
   ExpectDelim ('[', ENoSemi) ;
   IF MatchDelim (']') THEN
      RETURN OK ()                              (* [] - the empty set *)
   END ;
   LOOP
      RdConst (v, subcls, strf) ;
      IF strf THEN
         Err (ETypeErr) ;
         RETURN FALSE
      END ;
      IF MatchRange () THEN
         RdConst (hi, subcls, strf) ;
         IF strf THEN
            Err (ETypeErr) ;
            RETURN FALSE
         END
      ELSE
         hi := v
      END ;
      SetRangeBits (bytes, size, base, v, hi) ;
      IF MatchDelim (',') THEN
         (* another element *)
      ELSE
         EXIT
      END
   END ;
   ExpectDelim (']', ENoSemi) ;
   RETURN OK ()
END RdSetLiteral ;

PROCEDURE EmSetBlob (VAR bytes : ARRAY OF CHAR ; size : CARDINAL) : CARDINAL ;
(* Emit a set's bytes into the code stream behind a JMP over them - the same
   trick EmPushStrAddr uses for a string literal - and return the image offset
   of the first byte.  Nothing goes in the data segment: a .COM's DS already
   covers the code segment, which is why this port needs no `seg cs' where the
   original did (see CALC-COMPILE.md's typed-constant storage decision). *)
VAR here, k : CARDINAL ;
BEGIN
   IF size + 2 <= 127 THEN
      Ebyte (0EBH) ; Ebyte (VAL (BYTE, size))        (* JMP rel8 over it *)
   ELSE
      Ebyte (0E9H) ; Eword (size)                    (* JMP rel16 over it *)
   END ;
   here := pc ;
   k := 0 ;
   WHILE k < size DO
      Ebyte (VAL (BYTE, ORD (bytes [k]))) ;
      INC (k)
   END ;
   RETURN here
END EmSetBlob ;

PROCEDURE FoldSetIn (left, right : ERes ; VAR res : ERes) ;
(* `e IN s' where e is a compile-time ordinal and s a set whose bytes are
   already in the image: answer at compile time, exactly as TPSRC2's xsetin
   answers at run time (AH > 255 -> FALSE, else test the bit).  A run-time
   element or a run-time set is still ENoLib - that is the next milestone, and
   it must stay LOUD rather than silently answer wrong. *)
VAR off, base, size, rel, bidx, bit, m, o : CARDINAL ;
    isIn, foldable : BOOLEAN ;
    jl, jg, jmp : CARDINAL ;
BEGIN
   res.kind := 0 ;
   res.imm := 0 ;
   res.cls := TBool ;
   res.chr := FALSE ;
   IF right.cls # TSet THEN
      Err (ENoLib) ;
      RETURN
   END ;
   IF left.kind # 0 THEN
      (* A RUN-TIME element (`Upcase(Ch) in ['Y','N']', `Ch in ['a'..'z']').
         Materialise it in AX, subtract the set's base, reject the out-of-range
         values with the two signed tests the compiler declares (L and G), then
         index the bit array: byte = (e-base) DIV 8, bit = (e-base) MOD 8.
         The set's address is formed according to where its bytes live: an
         inline literal or typed constant is code-resident (image offset +
         LoadBias), a data set is an absolute or BP-relative address.  A set
         already addressed through DI and an element that itself needs DI are
         refused: the address would be lost. *)
      IF right.kind = 5 THEN
         Err (ENoLib) ;
         RETURN
      END ;
      LoadAtom (left) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF right.setbase # 0 THEN
         EmMovCxi (W16 (right.setbase)) ;
         EmSubAxCx ()
      END ;
      EmCmpAxi (0) ;
      jl := EmJcc (8CH, 0) ;                (* JL -> false *)
      EmCmpAxi (W16 (right.setsize * 8)) ;
      jg := EmJcc (8FH, 0) ;                (* JG -> false *)
      EmMovClAl () ;
      EmAndClImm (7) ;
      EmShrAx1 () ; EmShrAx1 () ; EmShrAx1 () ;   (* AX := byte index *)
      IF right.kind = 7 THEN
         EmMovBxi (W16 (right.setoff + LoadBias))
      ELSIF right.kind = 1 THEN
         IF symtab [right.idx].local THEN
            EmLeaBx ((right.setoff + right.boff) MOD 10000H)
         ELSE
            EmMovBxi ((right.setoff + right.boff + LoadBias) MOD 10000H)
         END
      ELSE
         Err (ENoLib) ;
         RETURN
      END ;
      EmAddBxAx () ;                        (* BX := the set's byte *)
      EmLdAlBx () ;
      EmMovDlImm (1) ;
      EmShlDlCl () ;                        (* DL := 1 << bit *)
      EmAndAlDl () ;
      EmMovAh0 () ;
      EmOrAxAx () ;
      EmRelSetcc (2) ;                      (* SETNE: the bit was set *)
      jmp := EmJmpNear (0) ;
      SetPatTgt (jl, pc) ;
      SetPatTgt (jg, pc) ;
      EmMovAxi (0) ;
      SetPatTgt (jmp, pc) ;
      res.kind := 2 ;
      res.cls := TBool ;
      RETURN
   END ;
   (* A code-resident set (an inline literal or a typed constant) folds at
      compile time.  A DATA set - a record field, local or global, or one
      addressed through DI - must be tested at run time: its byte is in the
      image's data area, not in cbuf.  A typed constant's offset is below
      dataBase; a global's is at or above it. *)
   foldable := (right.kind = 7) ;
   IF (right.kind = 1) AND NOT symtab [right.idx].local
      AND (right.setoff + right.boff < dataBase) THEN
      foldable := TRUE
   END ;
   IF NOT foldable THEN
      IF (left.imm >= 0) AND (left.imm <= 255) THEN
         base := right.setbase ; size := right.setsize ;
         rel := VAL (CARDINAL, left.imm) ;
         IF rel >= base THEN
            bidx := (rel - base) DIV 8 ;
            IF bidx < size THEN
               bit := (rel - base) MOD 8 ;
               m := 1 ;
               WHILE bit > 0 DO
                  m := m * 2 ; DEC (bit)
               END ;
               IF right.kind = 5 THEN
                  EmLdAlDiOff (bidx)
               ELSIF right.kind = 1 THEN
                  LoadSymVar (right.idx, (right.setoff + right.boff + bidx) MOD 10000H, 1)
               ELSE
                  Err (ENoLib) ;
                  RETURN
               END ;
               EmAndAlImm (m) ;
               EmMovAh0 () ;
               EmOrAxAx () ;
               EmRelSetcc (2) ;         (* SETNE: the bit was set *)
               res.kind := 2 ;
               res.cls := TBool ;
               RETURN
            END
         END
      END ;
      res.imm := 0 ;
      RETURN
   END ;
   isIn := FALSE ;
   IF (left.imm >= 0) AND (left.imm <= 255) THEN
      off := right.setoff ; base := right.setbase ; size := right.setsize ;
      rel := VAL (CARDINAL, left.imm) ;
      IF rel >= base THEN
         bidx := (rel - base) DIV 8 ;
         IF bidx < size THEN
            bit := (rel - base) MOD 8 ;
            m := 1 ;
            WHILE bit > 0 DO
               m := m * 2 ; DEC (bit)
            END ;
            o := VAL (CARDINAL, cbuf [off + bidx]) ;
            isIn := (o DIV m) MOD 2 # 0
         END
      END
   END ;
   res.imm := ORD (isIn)
END FoldSetIn ;

PROCEDURE RdSetBase (VAR baseCls : CARDINAL ; VAR lo, hi : LONGINT) ;
(* The base type of `set of ...': an ordinal range.  `Char' and `byte' are
   0..255; a literal subrange `a..b' is read directly.  A named or enumerated
   base is ENoLib for now - `set of Attributes' waits for enums. *)
VAR idx, subcls : CARDINAL ; strf : BOOLEAN ;
BEGIN
   baseCls := TScalar ;
   Skip () ;
   IF Alpha (CurCh ()) THEN
      GetWord () ;
      IF Search (wrd, idx) AND (symtab [idx].tag = KType) THEN
         IF symtab [idx].cls = TEnum THEN
            lo := symtab [idx].lo ;
            hi := symtab [idx].hi ;
            baseCls := TEnum
         ELSIF (symtab [idx].cls = TChar)
            OR ((symtab [idx].cls = TScalar) AND (symtab [idx].size = 1)) THEN
            lo := 0 ; hi := 255 ; baseCls := symtab [idx].cls
         ELSE
            Err (ENoLib)
         END
      ELSE
         Err (EUnknown)
      END
   ELSE
      RdConst (lo, subcls, strf) ;
      IF NOT MatchRange () THEN
         Err (ESimpType) ;
         RETURN
      END ;
      RdConst (hi, subcls, strf) ;
      IF (lo < 0) OR (hi > 255) OR (lo > hi) THEN
         Err (EConstRange)
      END
   END
END RdSetBase ;

PROCEDURE NewScratchStr () : CARDINAL ;
(* Allocate a fresh 256-byte global STRING and return its symbol index.

   A concatenation result needs STORAGE the emitted code can name.  Making the
   result a string VARIABLE (kind 1) is what keeps every downstream consumer
   untouched: Assignment, IoCall and ParseCmp already handle kind 1, so `s :=
   a + b', `writeln(a + b)' and `(a + b) = c' work with no code of their own.

   One scratch PER `+' in the source, so a repeated or nested concatenation
   never shares a destination - `a + b + c' is two occurrences and gets two
   scratch strings, and the first result survives until the second consumes it.
   (A loop reuses its site's scratch, which is correct because each execution
   writes before it reads.)  Recursion would break that, but this compiler
   compiles no procedures yet - see the item list.

   256 bytes is the STRING type's own size, length byte plus 255 characters:
   see ParseType's TkString arm and the predefined STRING in Inittur.  The name
   is a placeholder (nothing looks a scratch up by name) spelled with '@', as
   tmpA/tmpB are, so it cannot collide with a Modula-2 identifier. *)
BEGIN
   DropC (NewSym ("@@SC", KVar, TString, 256, 1, dc, 0, FALSE)) ;
   dc := dc + 256 ;
   RETURN symTop - 1
END NewScratchStr ;

PROCEDURE NewScratchWord () : CARDINAL ;
(* Two bytes for a dynamic set literal's element value. *)
BEGIN
   DropC (NewSym ("@@DW", KVar, TScalar, 2, 2, dc, 0, FALSE)) ;
   dc := dc + 2 ;
   RETURN symTop - 1
END NewScratchWord ;

PROCEDURE NewScratchReal () : CARDINAL ;
(* Six bytes of storage for a REAL function result, one per call site. *)
BEGIN
   DropC (NewSym ("@@RL", KVar, TReal, 6, 6, dc, 0, FALSE)) ;
   dc := dc + 6 ;
   RETURN symTop - 1
END NewScratchReal ;

PROCEDURE NewScratchRealBlock () : CARDINAL ;
(* Twelve bytes for a binary REAL operation: a followed by b. *)
BEGIN
   DropC (NewSym ("@@RB", KVar, TReal, 12, 6, dc, 0, FALSE)) ;
   dc := dc + 12 ;
   RETURN symTop - 1
END NewScratchRealBlock ;

PROCEDURE StrOperand (r : ERes) : BOOLEAN ;
(* Is r usable as one operand of `+'?  A STRING, or a CHAR - which can appear
   three ways: a quoted literal (cls TScalar with chr set), a CHAR variable
   (cls TChar), and a string element s[i] (cls TChar, kind 5).  A number is
   not, and neither is a BOOLEAN. *)
BEGIN
   RETURN (r.cls = TString) OR (r.cls = TChar) OR
          ((r.cls = TScalar) AND r.chr)
END StrOperand ;

PROCEDURE EmPushStrOperand (r : ERes) ;
(* Push the ADDRESS of one concatenation operand, converting a CHAR to a
   length-1 string first.

   A STRING operand is pushed exactly as cmpstr pushes one (EmPushStrAddr):
   a variable's value already IS its address, and a literal travels inline.

   A CHAR operand has no such address, so it is materialised as a
   `<length 1><character>' string in a fresh 2-byte scratch and the address of
   THAT is pushed.  This is TPSRC9's addch/addch2, which splice a character
   into a concatenation by building a one-character string.  The character is
   loaded into AL (LoadAtom), the character is stored at [coff+1] and the
   length 1 at [coff].  At most one operand of a concatenation is a CHAR -
   StrConcat rejects char+char - so at most one such scratch is ever made. *)
VAR coff : CARDINAL ;
BEGIN
   IF r.cls = TString THEN
      EmPushStrAddr (r)
   ELSE
      coff := dc ;
      dc := dc + 2 ;
      LoadAtom (r) ;                                   (* AX := the character *)
      EmStoreVar (FALSE, (coff + 1) MOD 10000H, 1) ;   (* [coff+1] := AL *)
      EmMovAxi (1) ;                                   (* AX := 1 *)
      EmStoreVar (FALSE, coff MOD 10000H, 1) ;         (* [coff] := AL = length *)
      EmPushVarAddr (FALSE, coff MOD 10000H)
   END
END EmPushStrOperand ;

PROCEDURE StrConcat (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ;
(* `left + right' for strings: TPSRC2's xconcat, emitted as two runtime calls.

   The layout is `<length byte><characters>' and `+' needs a place to build its
   result, so this allocates one 256-byte global scratch (NewScratchStr) and
   copies into it: first `dest := left' through the runtime's strstore, then
   `dest := dest + right' through strcat, which appends.  Using strstore for
   the left operand and strcat for the right keeps the append logic in one
   place and gives the compiler exactly one new entry to reach; it also means
   the two calls have the same argument shape (source pushed first, destination
   last, limit in CX), so the emission differs only in the entry named.

   The limit is 255 - the scratch's 255 usable characters.  An overflowing
   result is a RUNTIME ERROR with exit code 16, TP3's `String too long', not a
   truncation; see Runtime.EmitStrCat.

   The operator rule: `+' concatenates, anything else over a STRING is a type
   error, and char+char is ALSO a type error.  ISO Modula-2 gives no meaning to
   two characters summed, and inventing one (a two-character string?) would be
   a guess this compiler does not make; TP3's own behaviour there is not
   something the reference pins down.  That char+char choice is the one place
   this differs from a literal reading of the reference, and it is recorded
   here and in v-TP3-STRCAT.md rather than left to be discovered.

   The guard below is what ENFORCES that rule, and it only runs because
   BinOpEmit's hook routes a CHAR operand here too.  A hook that tested for a
   STRING operand only would send `'a' + 'b'' to the integer path instead and
   this test would never be reached - which is exactly what it did until
   t53_strcat_type caught it.  Three ways to fail it: a non-`+' operator over
   a string operand, an operand that is neither a string nor a CHAR (a number),
   and two CHARs with no STRING on either side. *)
VAR dest : CARDINAL ;
BEGIN
   (* A placeholder for the paths below that bail out through Err.  Err only
      records the first error and does not unwind, so the caller goes on to use
      res regardless: after `Err (ETypeErr)' in the guard, ParseAdd hands res
      straight back to to Assignment or to an enclosing concatenation.
      The placeholder's SHAPE therefore matters.  It must not claim to be a
      STRING, because the string consumers reach symtab[res.idx] for any TString
      (IoCall's `writeln' arm does) and idx is not a symbol here; and it must be
      something LoadAtom can fold, because the numeric consumers will try.  The
      integer 0 is both.  Leaving kind-2/TString here, as this once did, turned
      `writeln('a' + 'b')' - two CHARs, a type error - into a compiler segfault
      instead of an error message. *)
   res.kind := 0 ;
   res.imm := 0 ;
   res.cls := TScalar ;
   res.boff := 0 ;
   res.chr := FALSE ;
   IF (op # OpAdd) OR NOT StrOperand (left) OR NOT StrOperand (right) OR
      ((left.cls # TString) AND (right.cls # TString)) THEN
      Err (ETypeErr) ;           (* a STRING on the wrong operator, a number,
                                    or two CHARs *)
      RETURN
   END ;
   dest := NewScratchStr () ;
   (* dest := left *)
   EmPushStrOperand (left) ;
   EmPushVarAddr (FALSE, (symtab [dest].off) MOD 10000H) ;
   EmMovCxi (255) ;
   DropC (EmCall (TU_StrStore)) ;
   EmAddSp (4) ;                 (* pop the two addresses strstore took *)
   (* dest := dest + right *)
   EmPushStrOperand (right) ;
   EmPushVarAddr (FALSE, (symtab [dest].off) MOD 10000H) ;
   EmMovCxi (255) ;
   DropC (EmCall (TU_StrCat)) ;
   EmAddSp (4) ;
   res.kind := 1 ;
   res.idx := dest ;
   res.cls := TString ;
   res.boff := 0 ;
   res.chr := FALSE
END StrConcat ;

PROCEDURE ParseCmp (VAR r : ERes) ;
(* "=" | "<>" | "<" | "<=" | ">" | ">=" *)
VAR op : CARDINAL ;
    left, right : ERes ;
    f : LONGINT ;
    size, base, block, scratch : CARDINAL ;
BEGIN
   ParseAdd (r) ;
   LOOP
      op := 0 ;
      Skip () ;
      IF CurCh () = '=' THEN
         op := 1 ; DropCh (GetCh ())
      ELSIF (CurCh () = '<') AND (PeekAhead (1) = '>') THEN
         op := 2 ; DropCh (GetCh ()) ; DropCh (GetCh ())
      ELSIF CurCh () = '<' THEN
         IF PeekAhead (1) = '=' THEN
            op := 6 ; DropCh (GetCh ()) ; DropCh (GetCh ())
         ELSE
            op := 3 ; DropCh (GetCh ())
         END
      ELSIF CurCh () = '>' THEN
         IF PeekAhead (1) = '=' THEN
            op := 5 ; DropCh (GetCh ()) ; DropCh (GetCh ())
         ELSE
            op := 4 ; DropCh (GetCh ())
         END
      END ;
      IF op = 0 THEN
         IF KwAhead ("IN") THEN
            (* `e IN s' is at the comparison level in TP3 (TPSRC9 cmpin, 116).
               Only the compile-time case is implemented; see FoldSetIn. *)
            GetWord () ;
            left := r ;
            ParseAdd (right) ;
            FoldSetIn (left, right, r) ;
            RETURN
         END ;
         RETURN
      END ;
      left := r ;
      IF left.cls = TSet THEN
         (* Set comparison.  set_cmp returns a mask (bit 0 equal, bit 1 strict
            subset, bit 2 strict superset); the operator selects which bits
            answer it, and the shared EmRelSetcc arm turns the flags into a
            boolean.  The left address is pushed before the right operand is
            parsed, for the same DI reason as strings and set arithmetic. *)
         EmPushSetAddr (left) ;
         ParseAdd (right) ;
         IF NOT OK () THEN
            RETURN
         END ;
         IF right.cls # TSet THEN
            Err (ETypeErr) ;
            RETURN
         END ;
         IF NOT SetPairSize (left, right, size, base) THEN
            Err (ENoLib) ;
            RETURN
         END ;
         EmPushSetAddr (right) ;
         EmMovAxi (size) ;
         EmPushAx () ;
         DropC (EmCall (TU_SetCmp)) ;
         EmAddSp (4) ;
         CASE op OF
            1 : EmMovCxi (1) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ;
         |  2 : EmMovCxi (1) ; EmAndAxCx () ; EmXorAl01 () ;
               EmOrAxAx () ; EmRelSetcc (2) ;
         |  3 : EmMovCxi (2) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ;
         |  4 : EmMovCxi (4) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ;
         |  5 : EmMovCxi (5) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ;
         |  6 : EmMovCxi (3) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2)
         END ;
         r.kind := 2 ;
         r.cls := TBool
      ELSIF left.cls = TString THEN
         (* A string comparison: cmpstr, the entry TPSRC9's vcompare (133)
            reaches through TPSRC2's csteq/cstne/cstge/cstle/cstg/cstl
            wrappers (890-925).

            The operands are pushed as ADDRESSES, before the right-hand parse
            can clobber DI.  This is why the left is pushed here rather than
            through SaveLeft: a kind-5 left is a string FIELD whose address is
            in DI, and SaveLeft's job is to materialise a scalar in AX, which
            would read the length byte as a number (or, for a whole string,
            refuse it).  `if Sheet[UFX,UFY].Contents <> '' then' was exactly
            that: the CALC rung after Write(Value:FW:DEC).

            cmpstr returns AX = -1/0/+1 (see Runtime.mod for why a value and
            not flags), so the second half is exactly the numeric arm's: put
            the sign in the flags and let the shared six-arm table answer.
            EmOrAxAx is OR AX,AX rather than EmCmpAxi(0) on purpose: tests/
            check_8086.py reads every `CMP AX,0000' in the program region as
            an IF/WHILE/REPEAT test and requires a branch right after it, and
            a comparison used as a VALUE (writeln(a = b)) is not one. *)
         EmPushStrAddr (left) ;
         ParseAdd (right) ;
         IF (right.cls = TChar) OR ((right.cls = TScalar) AND right.chr) THEN
            (* `S <> Chr($FF)' / `S <> 'x'': a CHAR is a one-character string.
               Materialise it as a counted scratch so cmpstr sees the same
               layout as every other string operand. *)
            scratch := NewScratchStr () ;
            IF right.kind = 0 THEN
               EmMovAxi (W16 (right.imm)) ;
               EmStoreVar (FALSE, (symtab [scratch].off + 1) MOD 10000H, 1) ;
               EmMovAxi (1) ;
               EmStoreVar (FALSE, symtab [scratch].off, 1)
            ELSE
               LoadAtom (right) ;
               EmStoreVar (FALSE, (symtab [scratch].off + 1) MOD 10000H, 1) ;
               EmMovAxi (1) ;
               EmStoreVar (FALSE, symtab [scratch].off, 1)
            END ;
            right.kind := 1 ; right.idx := scratch ; right.cls := TString ;
            right.sz := 256 ; right.boff := 0
         END ;
         IF right.cls # TString THEN
            Err (ETypeErr) ;         (* a string compared with a number *)
            RETURN
         END ;
         EmPushStrAddr (right) ;
         DropC (EmCall (TU_CmpStr)) ;
         EmAddSp (4) ;
         EmOrAxAx () ;
         EmRelSetcc (op) ;
         r.kind := 2 ;
         r.cls := TBool
      ELSIF left.cls = TReal THEN
         (* REAL comparison: recmp takes one 12-byte block holding a then b.
            SaveLeft parks the left address; the right is copied first when it
            is DI-addressed, before the block copy clobbers DI. *)
         SaveLeft (left) ;
         ParseAdd (right) ;
         IF NOT OK () THEN
            RETURN
         END ;
         IF (right.cls = TScalar) AND (right.kind = 0) THEN
            scratch := NewScratchReal () ;
            EmCopyRealTo (symtab [scratch].off, right) ;
            right.idx := scratch ; right.kind := 1 ; right.cls := TReal ;
            right.sz := 6 ; right.boff := 0
         END ;
         IF right.cls # TReal THEN
            Err (ETypeErr) ;
            RETURN
         END ;
         block := NewScratchRealBlock () ;
         IF right.kind = 5 THEN
            EmCopyRealTo (symtab [block].off + 6, right) ;
            EmCopyRealTo (symtab [block].off, left)
         ELSE
            EmCopyRealTo (symtab [block].off, left) ;
            EmCopyRealTo (symtab [block].off + 6, right)
         END ;
         EmPushVarAddr (FALSE, symtab [block].off) ;
         DropC (EmCall (TU_RealCmp)) ;
         EmAddSp (2) ;
         EmOrAxAx () ;
         EmRelSetcc (op) ;
         r.kind := 2 ;
         r.cls := TBool
      ELSE
         SaveLeft (left) ;
         ParseAdd (right) ;
         IF (right.cls = TString) OR (right.cls = TSet) THEN
            Err (ETypeErr) ;         (* a number compared with a string/set *)
            RETURN
         END ;
         IF (left.kind = 0) AND (right.kind = 0) THEN
         IF ConstCmp (op, left.imm, right.imm, f) THEN
            r.kind := 0 ;
            r.imm := f ;
            r.cls := TBool
         ELSE
            r.kind := 0 ;
            r.imm := 0 ;
            r.cls := TBool
         END
         ELSE
            LoadPair (left, right) ;
            EmCmpAxCx () ;
         EmRelSetcc (op) ;
         r.kind := 2 ;
         r.cls := TBool
         END
      END
   END
END ParseCmp ;

PROCEDURE ParseAdd (VAR r : ERes) ;
VAR op : CARDINAL ;
    left, right : ERes ;
BEGIN
   ParseMul (r) ;
   LOOP
      op := 0 ;
      Skip () ;
      IF CurCh () = '+' THEN
         op := OpAdd ; DropCh (GetCh ())
      ELSIF CurCh () = '-' THEN
         op := OpSub ; DropCh (GetCh ())
      ELSIF KwAhead ("OR") THEN
         GetWord () ;
         op := TkOr
      ELSE
         RETURN
      END ;
      left := r ;
      IF left.cls = TSet THEN
         (* Set union/difference.  The left address goes on the stack BEFORE
            the right is parsed: a DI-addressed set field must survive the
            right-hand expression.  `OR' is boolean, not set union. *)
         IF (op = OpAdd) OR (op = OpSub) THEN
            EmPushSetAddr (left) ;
            ParseMul (right) ;
            IF NOT OK () THEN
               RETURN
            END ;
            IF right.cls # TSet THEN
               Err (ETypeErr) ;
               RETURN
            END ;
            IF right.kind = 9 THEN
               MaterializeDyn (right, left.setbase, left.setsize)
            END ;
            IF op = OpAdd THEN
               SetBinEmit (1, left, right, r)
            ELSE
               SetBinEmit (2, left, right, r)
            END
         ELSE
            Err (ETypeErr) ;
            RETURN
         END
      ELSE
         SaveLeft (left) ;
         ParseMul (right) ;
         IF NOT OK () THEN
            RETURN
         END ;
         IF right.cls = TSet THEN
            Err (ETypeErr) ;
            RETURN
         END ;
         BinOpEmit (op, left, right, r)
      END
   END
END ParseAdd ;

PROCEDURE ParseMul (VAR r : ERes) ;
VAR op : CARDINAL ;
    left, right : ERes ;
BEGIN
   ParseNeg (r) ;
   LOOP
      op := 0 ;
      Skip () ;
      IF CurCh () = '*' THEN
         op := OpMul ; DropCh (GetCh ())   (* OpAdd here meant a*b -> a+b *)
      ELSIF CurCh () = '/' THEN
         op := OpDiv ; DropCh (GetCh ())
      ELSIF KwAhead ("DIV") THEN
         GetWord () ; op := TkDiv
      ELSIF KwAhead ("MOD") THEN
         GetWord () ; op := TkMod
      ELSIF KwAhead ("AND") THEN
         GetWord () ; op := TkAnd
      ELSIF KwAhead ("SHL") THEN
         GetWord () ; op := OpShl
      ELSIF KwAhead ("SHR") THEN
         GetWord () ; op := OpShr
      ELSE
         RETURN
      END ;
      left := r ;
      IF left.cls = TSet THEN
         (* Set intersection.  Same push-before-the-right rule as ParseAdd. *)
         IF op = OpMul THEN
            EmPushSetAddr (left) ;
            ParseNeg (right) ;
            IF NOT OK () THEN
               RETURN
            END ;
            IF right.cls # TSet THEN
               Err (ETypeErr) ;
               RETURN
            END ;
            SetBinEmit (0, left, right, r)
         ELSE
            Err (ETypeErr) ;
            RETURN
         END
      ELSE
         SaveLeft (left) ;
         ParseNeg (right) ;
         IF NOT OK () THEN
            RETURN
         END ;
         IF right.cls = TSet THEN
            Err (ETypeErr) ;
            RETURN
         END ;
         BinOpEmit (op, left, right, r)
      END
   END
END ParseMul ;

PROCEDURE ParseNeg (VAR r : ERes) ;
BEGIN
   Skip () ;
   IF CurCh () = '+' THEN
      DropCh (GetCh ()) ;
      ParseNeg (r) ;
      RETURN
   ELSIF CurCh () = '-' THEN
      DropCh (GetCh ()) ;
      ParseNeg (r) ;
      IF r.cls = TReal THEN
         r.idx := NewScratchReal () ;
         EmCopyRealTo (symtab [r.idx].off, r) ;
         EmXorByteGlob (symtab [r.idx].off + 5, 80H) ;
         r.kind := 1 ;
         r.cls := TReal ;
         r.sz := 6 ;
         r.boff := 0
      ELSIF r.kind = 0 THEN
         r.imm := VAL (LONGINT, W16 (0 - r.imm))
      ELSE
         LoadAtom (r) ;
         EmNegAx () ;
         r.kind := 2
      END ;
      RETURN
   ELSIF KwAhead ("NOT") THEN
      GetWord () ;
      ParseNeg (r) ;
      (* TPSRC9 neglevel branches on the operand's type before emitting
         anything: CMP CL,#$0A (integer) -> NOT AX, CMP CL,#$0B (boolean)
         -> XOR AL,#01, anything else -> error.  This used to emit NOT AX
         for both, so `not (a = a)' produced 0FFFEh and the runtime's
         wrbool test ([BP+4] <> 0) read it as TRUE.

         The integer constant fold stays: the 16 bits are the same either
         way.  A boolean constant must not go through BitNot - 0FFFFH-1 is
         0FFFEh, which wrbool also reads as TRUE - so it is loaded and
         xor-ed, exactly as neglevel does it. *)
      IF r.cls = TBool THEN
         LoadAtom (r) ;
         EmXorAl01 () ;
         r.kind := 2
      ELSIF r.cls = TScalar THEN
         IF r.kind = 0 THEN
            r.imm := BitNot (r.imm)
         ELSE
            LoadAtom (r) ;
            EmNotAx () ;
            r.kind := 2
         END
      ELSE
         Err (ETypeErr)
      END ;
      RETURN
   END ;
   ParseAtom (r)
END ParseNeg ;

PROCEDURE WithLookup (nm : ARRAY OF CHAR ; VAR r : ERes) : BOOLEAN ;
(* Resolve a bare identifier against the active WITH scopes, innermost first.
   ISO Pascal lets a record field shadow an outer declaration, so this is
   consulted BEFORE Search.  The result is filled exactly as a variable
   reference: kind 1 (base symbol + boff) for a record variable or a
   constant-index element, kind 5 (address in DI) for a run-time-indexed one,
   where the base is reloaded from the WITH slot because the body may have
   used DI. *)
VAR w, fi : CARDINAL ;
    found : BOOLEAN ;
BEGIN
   w := withN ;
   WHILE w > 0 DO
      DEC (w) ;
      fi := withFF [w] ;
      found := FALSE ;
      WHILE (fi < withFL [w]) AND NOT found DO
         IF NameEq (fields [fi].name, nm) THEN
            found := TRUE
         ELSE
            INC (fi)
         END
      END ;
      IF found THEN
         IF withIsDI [w] THEN
            EmLdDiGlob (withSlot [w]) ;
            IF fields [fi].off # 0 THEN
               EmAddDiImm (fields [fi].off)
            END ;
            r.kind := 5
         ELSE
            r.kind := 1 ;
            r.setoff := symtab [withIdx [w]].off ;
            r.boff := W16 (VAL (LONGINT, withBoff [w])
                           + VAL (LONGINT, fields [fi].off))
         END ;
         r.idx := withIdx [w] ;
         r.cls := fields [fi].cls ;
         r.sz := fields [fi].size ;
         r.fldFirst := fields [fi].fldFirst ;
         r.fldLast := fields [fi].fldLast ;
         r.arrIdx := fields [fi].arrIdx ;
         r.ptrElem := fields [fi].ptrElem ;
         r.hasBounds := ((fields [fi].cls = TScalar) OR (fields [fi].cls = TEnum)
                         OR (fields [fi].cls = TChar)) AND
                        (fields [fi].lo # fields [fi].hi) ;
         r.blo := fields [fi].lo ; r.bhi := fields [fi].hi ;
         IF r.cls = TSet THEN
            r.setbase := fields [fi].elem ;
            r.setsize := fields [fi].size
         END ;
         r.chr := FALSE ;
         RETURN TRUE
      END
   END ;
   RETURN FALSE
END WithLookup ;

PROCEDURE ParseAtom (VAR r : ERes) ;
(* const | variable | func(params) | '(' expr ')' | '[' set ']' *)
VAR idx : CARDINAL ;
    strf : BOOLEAN ;
    quoted : BOOLEAN ;
    ssize, sbase : CARDINAL ;
    sbuf : ARRAY [0..31] OF CHAR ;
    uj1, uj2 : CARDINAL ;
    litStart, scratch, asciiAddr, savePos : CARDINAL ;
    dyn, acc, conArg : ERes ;
BEGIN
   r.chr := FALSE ;            (* default: not a quoted char literal *)
   Skip () ;
   IF CurCh () = '(' THEN
      DropCh (GetCh ()) ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      RETURN
   END ;
   IF CurCh () = '[' THEN
      (* An inline set literal.  A literal whose first element is a variable
         (e.g. `[Storage[Index]]') is dynamic: evaluate the element once and
         mark it kind 9, to be materialised when the target's base/size is
         known.  Constant literals stay code-resident. *)
      savePos := srcPos ;
      DropCh (GetCh ()) ;
      Skip () ;
      IF Alpha (CurCh ()) THEN
         GetWord () ;
         IF Search (wrd, idx) AND ((symtab [idx].tag = KVar) OR
                                   (symtab [idx].tag = KFunc)) THEN
            srcPos := savePos + 1 ;
            ParseExpr (dyn) ;
            ExpectDelim (']', ENoSemi) ;
            IF NOT OK () THEN
               RETURN
            END ;
            IF (dyn.cls # TScalar) AND (dyn.cls # TChar) AND
               (dyn.cls # TEnum) THEN
               Err (ETypeErr) ;
               RETURN
            END ;
            scratch := NewScratchWord () ;
            LoadAtom (dyn) ;
            EmStoreVar (FALSE, symtab [scratch].off, 2) ;
            r.kind := 9 ;
            r.cls := TSet ;
            r.setbase := 0 ;
            r.setsize := 0 ;
            r.dynElem := scratch ;
            RETURN
         END
      END ;
      srcPos := savePos ;
      ssize := 32 ;
      sbase := 0 ;
      IF RdSetLiteral (sbase, ssize, sbuf) THEN
         r.kind := 7 ;
         r.cls := TSet ;
         r.setoff := EmSetBlob (sbuf, ssize) ;
         r.setbase := sbase ;
         r.setsize := ssize
      END ;
      RETURN
   END ;
   IF (CurCh () = '$') OR (Digit (CurCh ())) OR (ORD (CurCh ()) = AposC)
      OR (CurCh () = '^') OR (CurCh () = '#') THEN
      (* remember that this was a quoted literal BEFORE RdConst consumes it:
         RdConst reports a 1-character literal as TScalar (its char code),
         which is right for "c := 'a'" but would make writeln('a') print 97.
         Mark it so the writer picks the char entry, not the integer one.  A
         caret (^M) or decimal (#27) character constant is a character too. *)
      quoted := (ORD (CurCh ()) = AposC) OR (CurCh () = '^')
                OR (CurCh () = '#') ;
      litStart := srcPos ;
      RdConst (r.imm, r.cls, strf) ;
      r.chr := quoted AND (r.cls = TScalar) AND NOT strf ;
      IF r.cls = TReal THEN
         (* A REAL literal is converted at run time by ascreal.  Keep the
            literal text as an ASCIIZ code blob and call real_val into a
            six-byte scratch; the expression then behaves like a REAL
            variable whose address is the scratch. *)
         scratch := NewScratchReal () ;
         asciiAddr := EmAsciiZLiteral (litStart, srcPos) ;
         EmPushVarAddr (FALSE, symtab [scratch].off) ;
         EmPushVarAddr (FALSE, asciiAddr) ;
         DropC (EmCall (TU_RealVal)) ;
         EmAddSp (4) ;
         EmLeaDi (FALSE, symtab [scratch].off) ;
         r.idx := scratch ;
         r.kind := 5 ;
         r.cls := TReal ;
         r.sz := 6 ;
         RETURN
      END ;
      IF strf THEN
         (* A string literal is legal here as a *value* - it is not rejected
            at this point, because writeln('hi') needs it and IoCall is the
            only place that knows how to emit one.  Everywhere else the
            literal has to end up as a machine word, and that is caught by
            LoadAtom, which refuses a TString. *)
         r.strx := rdStrX ;
         r.kind := 3 ;
         RETURN
      END ;
      r.kind := 0 ;
      RETURN
   END ;
   IF NOT Alpha (CurCh ()) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   GetWord () ;
   IF WithLookup (wrd, r) THEN
      ParseSub (r) ;
      RETURN
   END ;
   IF NameEq (wrd, "NIL") THEN
      r.kind := 0 ;
      r.cls := TPtr ;
      r.imm := 0 ;
      r.sz := 2 ;
      RETURN
   END ;
   IF NameEq (wrd, "ADDR") THEN
      (* Addr(x): the run-time address of x, as a pointer value in AX.  TP3
         spells this Addr; the @ operator is a later Turbo spelling and is not
         part of the TP3 subset yet. *)
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      Skip () ;
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      GetWord () ;
      ParseVar (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF r.kind = 5 THEN
         EmMovAxDi ()
      ELSIF r.kind = 1 THEN
         IF symtab [r.idx].isVar THEN
            LoadSymVar (r.idx, symtab [r.idx].off, 2)
         ELSE
            EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
            EmPopAx ()
         END
      ELSE
         Err (ETypeErr) ;
         RETURN
      END ;
      r.kind := 2 ;
      r.cls := TPtr ;
      r.sz := 2 ;
      r.idx := 0 ;
      RETURN
   END ;
   IF NameEq (wrd, "SEG") THEN
      (* TP3 Seg(x): the current DS.  The argument is parsed for its type
         and side effects; the .COM has one segment. *)
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      EmMovAxDs () ;                     (* MOV AX,DS *)
      r.kind := 2 ; r.cls := TScalar ; r.sz := 2 ;
      RETURN
   END ;
   IF NameEq (wrd, "OFS") THEN
      (* TP3 Ofs(x): the run-time address of x. *)
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      Skip () ;
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      GetWord () ;
      ParseVar (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF r.kind = 5 THEN
         EmMovAxDi ()
      ELSIF r.kind = 1 THEN
         EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
         EmPopAx ()
      ELSE
         Err (ETypeErr) ;
         RETURN
      END ;
      r.kind := 2 ; r.cls := TScalar ; r.sz := 2 ;
      RETURN
   END ;
   IF NOT Search (wrd, idx) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   IF (symtab [idx].tag = KVar) AND (symtab [idx].resvar # 0) THEN
      (* A function's result variable shadows its own name inside the body;
         a following '(' means this is a recursive call, not a read of the
         result slot. *)
      Skip () ;
      IF CurCh () = '(' THEN
         idx := symtab [idx].resvar
      END
   END ;
   IF symtab [idx].tag = KConst THEN
      r.kind := 0 ;
      r.imm := symtab [idx].lval ;
      r.cls := symtab [idx].cls ;
      RETURN
   ELSIF symtab [idx].tag = KFunc THEN
      ParseCall (idx) ;
      IF symtab [idx].cls = TReal THEN
         (* A REAL function returns into the caller's six-byte scratch; DI is
            reloaded with its address so real consumers can use the value. *)
         EmLeaDi (FALSE, symtab [callScratch].off) ;
         r.kind := 5 ;
         r.cls := TReal ;
         r.sz := 6
      ELSE
         r.kind := 2 ;
         r.cls := symtab [idx].cls
      END ;
      RETURN
   ELSIF (symtab [idx].tag = KType) AND (symtab [idx].cls = TChar)
      AND (CurCh () = '(') THEN
      (* TP3 also spells the character cast `Char(n)', not only `Chr(n)'. *)
      DropCh (GetCh ()) ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF (r.cls # TScalar) AND (r.cls # TChar) THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      IF r.kind = 0 THEN
         r.imm := VAL (LONGINT, W16 (r.imm) MOD 256) ;
         r.chr := TRUE
      ELSE
         LoadAtom (r) ;
         r.kind := 2 ;
         r.chr := FALSE
      END ;
      r.cls := TChar ;
      r.sz := 1 ;
      RETURN
   ELSIF (symtab [idx].tag = KVar) OR (symtab [idx].tag = KType) THEN
      (* ParseVar initialises boff to 0 and then ParseSub folds any constant
         subscript into it.  Do NOT reset boff here: doing so after ParseVar
         returns threw away the subscript, so s[i] read/wrote off+0 (the
         length byte) while still reporting itself as a char.  This was
         latent for arrays because an array cannot be declared yet, so no
         fixture had ever exercised the fold. *)
      ParseVar (r) ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Chr) THEN
      (* Chr(n): the character with code n.  A constant folds; otherwise the
         integer is loaded and its class becomes CHAR.  The value is one byte,
         so an assignment stores AL and a CHAR writer uses AL. *)
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF (r.cls # TScalar) AND (r.cls # TChar) THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      IF r.kind = 0 THEN
         r.imm := VAL (LONGINT, W16 (r.imm) MOD 256) ;
         r.chr := TRUE
      ELSE
         LoadAtom (r) ;
         r.kind := 2 ;
         r.chr := FALSE
      END ;
      r.cls := TChar ;
      r.sz := 1 ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Eof) THEN
      (* Eof(F): text/typed-file end of file.  The runtime compares the DOS
         current position with the file size and also remembers a ^Z seen by
         the text reader. *)
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      IF OK () THEN
         IF (r.kind = 1) AND
            ((r.cls = TText) OR (r.cls = TFile)) THEN
            EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
            DropC (EmCall (TU_FileEof)) ;
            EmAddSp (2) ;
            r.kind := 2 ;
            r.cls := TBool ;
            r.chr := FALSE
         ELSE
            Err (ETypeErr)
         END
      END ;
      ExpectDelim (')', ENoSemi) ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_IoResult) THEN
      (* IOResult: the last file operation's DOS status; reading it clears the
         slot in the runtime.  It is a no-argument function. *)
      IF MatchDelim ('(') THEN
         ExpectDelim (')', ENoSemi)
      END ;
      DropC (EmCall (TU_IoResult)) ;
      r.kind := 2 ;
      r.cls := TScalar ;
      r.chr := FALSE ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_UpCase) THEN
      (* UpCase(c): a CHAR function.  A constant folds; otherwise AL is
         mapped 'a'..'z' -> 'A'..'Z' and left alone outside that range.  The
         test is JL/JG (signed), which is the same answer for 0..127 chars and
         leaves 128..255 unchanged; it also stays inside the four branch
         conditions this compiler declares (check_8086's set). *)
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF (r.cls # TChar) AND (r.cls # TScalar) THEN
         Err (ETypeErr) ;           (* the STRING form is not implemented *)
         RETURN
      END ;
      IF r.kind = 0 THEN
         IF (r.imm >= VAL (LONGINT, ORD ('a')))
            AND (r.imm <= VAL (LONGINT, ORD ('z'))) THEN
            r.imm := r.imm - 32
         END ;
         r.kind := 0 ;
         r.cls := TChar ;
         r.chr := TRUE ;
         RETURN
      END ;
      LoadAtom (r) ;
      EmCmpAlImm (ORD ('a')) ;
      uj1 := EmJcc (8CH, 0) ;       (* JL -> leave it *)
      EmCmpAlImm (ORD ('z')) ;
      uj2 := EmJcc (8FH, 0) ;       (* JG -> leave it *)
      EmSubAlImm (32) ;
      SetPatTgt (uj1, pc) ;
      SetPatTgt (uj2, pc) ;
      EmMovAh0 () ;
      r.kind := 2 ;
      r.cls := TChar ;
      r.chr := FALSE ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND
         ((symtab [idx].cls = BI_Succ) OR (symtab [idx].cls = BI_Pred)) THEN
      (* Succ(x) / Pred(x) on an ordinal.  CALC's `FX := Succ(FX)' is the
         first use.  A constant folds; otherwise load the value and INC/DEC
         it, preserving the operand's class so an assignment back to a CHAR
         subrange stores one byte as before. *)
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF (r.cls # TChar) AND (r.cls # TScalar) AND (r.cls # TEnum) THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      IF r.kind = 0 THEN
         IF symtab [idx].cls = BI_Succ THEN
            r.imm := VAL (LONGINT, W16 (r.imm + 1))
         ELSE
            r.imm := VAL (LONGINT, W16 (r.imm - 1))
         END
      ELSE
         LoadAtom (r) ;
         IF symtab [idx].cls = BI_Succ THEN
            EmIncAx ()
         ELSE
            EmDecAx ()
         END ;
         r.kind := 2
      END ;
      r.chr := FALSE ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_KeyPressed) THEN
      (* KeyPressed: a boolean FUNCTION with no argument, and TP3 lets it be
         written without a parameter list (`until KeyPressed'). *)
      EmCrtSeq (CrtKey) ;
      r.kind := 2 ;
      r.cls := TBool ;
      r.chr := FALSE ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND
         ((symtab [idx].cls = BI_Abs) OR (symtab [idx].cls = BI_Sqrt)
          OR (symtab [idx].cls = BI_Ln) OR (symtab [idx].cls = BI_Exp)
          OR (symtab [idx].cls = BI_Sin) OR (symtab [idx].cls = BI_Cos)
          OR (symtab [idx].cls = BI_Arctan) OR (symtab [idx].cls = BI_Int)) THEN
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF (r.cls = TScalar) AND (r.kind = 0) THEN
         scratch := NewScratchReal () ;
         EmCopyRealTo (symtab [scratch].off, r) ;
         r.idx := scratch ; r.kind := 1 ; r.cls := TReal ;
         r.sz := 6 ; r.boff := 0
      END ;
      IF r.cls # TReal THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      IF symtab [idx].cls = BI_Abs THEN
         RealUnary (TU_RealAbs, r)
      ELSIF symtab [idx].cls = BI_Sqrt THEN
         RealUnary (TU_RealSqrt, r)
      ELSIF symtab [idx].cls = BI_Ln THEN
         RealUnary (TU_RealLn, r)
      ELSIF symtab [idx].cls = BI_Exp THEN
         RealUnary (TU_RealExp, r)
      ELSIF symtab [idx].cls = BI_Sin THEN
         RealUnary (TU_RealSin, r)
      ELSIF symtab [idx].cls = BI_Cos THEN
         RealUnary (TU_RealCos, r)
      ELSIF symtab [idx].cls = BI_Arctan THEN
         RealUnary (TU_RealArctan, r)
      ELSE
         RealUnary (TU_RealIntFunc, r)
      END ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Sqr) THEN
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF r.cls # TReal THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      RealBin (OpMul, r, r, r) ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_SizeOf) THEN
      IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ;
      savePos := srcPos ;
      Skip () ;
      IF Alpha (CurCh ()) THEN
         GetWord () ;
         IF Search (wrd, idx) AND (symtab [idx].tag = KType) THEN
            r.kind := 0 ; r.cls := TScalar ; r.imm := symtab [idx].size ;
            ExpectDelim (')', ENoSemi) ;
            RETURN
         END
      END ;
      srcPos := savePos ;
      ParseExpr (r) ;
      IF OK () THEN
         r.kind := 0 ; r.cls := TScalar ; r.imm := VarSize (r)
      END ;
      ExpectDelim (')', ENoSemi) ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND
         ((symtab [idx].cls = BI_FilePos) OR (symtab [idx].cls = BI_FileSize)) THEN
      IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () OR (r.kind # 1) OR
         ((r.cls # TFile) AND (r.cls # TText) AND (r.cls # TUntyp)) THEN
         Err (ETypeErr) ; RETURN
      END ;
      EmMovAxi (symtab [r.idx].elem) ; EmPushAx () ;
      EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
      IF symtab [idx].cls = BI_FilePos THEN
         DropC (EmCall (TU_FilePos))
      ELSE
         DropC (EmCall (TU_FileSize))
      END ;
      EmAddSp (4) ;
      r.kind := 2 ; r.cls := TScalar ; r.sz := 2 ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Random) THEN
      IF MatchDelim ('(') THEN
         ParseExpr (r) ;
         ExpectDelim (')', ENoSemi) ;
         IF NOT OK () THEN RETURN END ;
         IF (r.cls # TScalar) AND (r.cls # TChar) THEN
            Err (ETypeErr) ; RETURN
         END ;
         LoadAtom (r) ; EmPushAx ()
      ELSE
         EmMovAxi (0) ; EmPushAx ()
      END ;
      DropC (EmCall (TU_Random)) ; EmAddSp (2) ;
      r.kind := 2 ; r.cls := TScalar ; r.sz := 2 ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Pos) THEN
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      IF OK () AND (r.cls = TString) THEN
         EmPushStrAddr (r) ;
         ExpectDelim (',', ENoSemi) ;
         ParseExpr (r) ;
         IF OK () AND (r.cls = TString) THEN
            EmPushStrAddr (r) ;
            DropC (EmCall (TU_StrPos)) ;
            EmAddSp (4) ;
            r.kind := 2 ;
            r.cls := TScalar ;
            r.sz := 2
         ELSIF OK () THEN
            Err (ETypeErr)
         END
      ELSIF OK () THEN
         Err (ETypeErr)
      END ;
      ExpectDelim (')', ENoSemi) ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Concat) THEN
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      IF CurCh () = ')' THEN
         scratch := NewScratchStr () ;
         EmStoreVar (FALSE, symtab [scratch].off, 1) ;
         r.kind := 1 ; r.idx := scratch ; r.cls := TString ; r.sz := 256 ;
         ExpectDelim (')', ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      IF OK () AND NOT StrOperand (r) THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      IF OK () AND MatchDelim (',') THEN
         LOOP
            ParseExpr (conArg) ;
            IF NOT OK () THEN
               RETURN
            END ;
            IF NOT StrOperand (conArg) THEN
               Err (ETypeErr) ;
               RETURN
            END ;
            StrConcat (OpAdd, r, conArg, acc) ;
            r := acc ;
            IF NOT MatchDelim (',') THEN
               EXIT
            END
         END
      END ;
      ExpectDelim (')', ENoSemi) ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Copy) THEN
      (* Copy(S, start, len): a counted-string result in a fresh 256-byte
         scratch.  S's address is parked while start/len are parsed, then the
         four words are re-pushed in the runtime's [source,dest,start,len]
         order. *)
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      IF OK () AND (r.cls = TString) AND
         ((r.kind = 1) OR (r.kind = 3) OR (r.kind = 5)) THEN
         EmPushStrAddr (r) ;           (* park S *)
         ExpectDelim (',', ENoSemi) ;
         ParseExpr (r) ;
         IF OK () AND ((r.cls = TScalar) OR (r.cls = TChar)) THEN
            LoadAtom (r) ; EmPushAx () ;
            ExpectDelim (',', ENoSemi) ;
            ParseExpr (r) ;
            IF OK () AND ((r.cls = TScalar) OR (r.cls = TChar)) THEN
               LoadAtom (r) ; EmPushAx () ;
               scratch := NewScratchStr () ;
               EmPushVarAddr (FALSE, symtab [scratch].off) ;
               EmPopAx () ;             (* dest *)
               EmPopBx () ;             (* len *)
               EmPopCx () ;             (* start *)
               EmPopDx () ;             (* source *)
               EmPushBx () ; EmPushCx () ; EmPushAx () ; EmPushDx () ;
               DropC (EmCall (TU_StrCopy)) ;
               EmAddSp (8) ;
               r.kind := 1 ; r.idx := scratch ; r.cls := TString ;
               r.sz := 256 ; r.boff := 0 ; r.chr := FALSE
            ELSIF OK () THEN
               Err (ETypeErr)
            END
         ELSIF OK () THEN
            Err (ETypeErr)
         END ;
         ExpectDelim (')', ENoSemi)
      ELSIF OK () THEN
         Err (ETypeErr)
      END ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Ord) THEN
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF (r.cls # TChar) AND (r.cls # TEnum) AND (r.cls # TScalar)
         AND (r.cls # TBool) THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      LoadAtom (r) ;
      r.kind := 2 ;
      r.cls := TScalar ;
      r.chr := FALSE ;
      RETURN
   ELSIF (symtab [idx].tag = KBuiltin) AND
         ((symtab [idx].cls = BI_Round) OR (symtab [idx].cls = BI_Trunc)) THEN
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF r.cls = TReal THEN
         IF r.kind = 5 THEN
            EmPushDi ()
         ELSIF r.kind = 1 THEN
            EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
         ELSE
            Err (ETypeErr) ;
            RETURN
         END ;
         IF symtab [idx].cls = BI_Round THEN
            EmMovAxi (1)
         ELSE
            EmMovAxi (0)
         END ;
         EmPushAx () ;
         DropC (EmCall (TU_RealToInt)) ;
         EmAddSp (4) ;
         r.kind := 2 ;
         r.cls := TScalar ;
         r.sz := 2 ;
         RETURN
      ELSIF (r.cls = TScalar) OR (r.cls = TChar) OR (r.cls = TEnum) THEN
         LoadAtom (r) ;
         r.kind := 2 ;
         r.cls := TScalar ;
         r.sz := 2 ;
         RETURN
      ELSE
         Err (ETypeErr) ;
         RETURN
      END ;
   ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Length) THEN
      (* LENGTH (s): the string's length byte, loaded inline.  No runtime
         entry, and no address is pushed - a string's value already carries its
         length at [addr].  A literal is emitted inline (EmStrBlob) and the
         byte is read from that image offset. *)
      IF NOT MatchDelim ('(') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF r.cls # TString THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      IF r.kind = 5 THEN
         (* A string field/element addressed by DI (e.g. a typed-constant
            array element): its length byte is at [DI]. *)
         EmLdAlDi () ; EmMovAh0 ()
      ELSIF (r.kind = 1) AND symtab [r.idx].isVar THEN
         (* VAR string: the slot holds the address; read the length byte
            through that pointer. *)
         IF r.boff # 0 THEN
            Err (ENoLib)
         ELSE
            EmLoadVarIndSym (r.idx, 1)
         END
      ELSIF r.kind = 1 THEN
         LoadSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, 1)
      ELSIF r.kind = 3 THEN
         EmLoadVar (FALSE, EmStrBlob (r), 1)
      ELSE
         Err (ENoLib) ;
         RETURN
      END ;
      EmMovAh0 () ;
      r.kind := 2 ;
      r.cls := TScalar ;
      r.chr := FALSE ;
      RETURN
   ELSE
      Err (EUnknown)
   END
END ParseAtom ;

PROCEDURE AddPend (kind, who, place : CARDINAL) ;
BEGIN
   IF nPend < MaxPend THEN
      pend [nPend].kind := kind ;
      pend [nPend].who := who ;
      pend [nPend].place := place ;
      INC (nPend)
   ELSE
      Err (ECompOvf)
   END
END AddPend ;

PROCEDURE ParmSlot (idx, k : CARDINAL) : CARDINAL ;
(* The stack slot of argument k (0-based) of procedure/function idx, from the
   parameter list recorded on the symbol.  Out of range means the source passed
   more arguments than there are parameters: keep the old two-byte assumption
   rather than inventing an arity error here. *)
VAR pi : CARDINAL ;
BEGIN
   IF (symtab [idx].parmCount = 0) OR (k >= symtab [idx].parmCount) THEN
      RETURN 2
   END ;
   pi := symtab [idx].parmFirst + k ;
   RETURN ParamSlotBytes (symtab [pi])
END ParmSlot ;

PROCEDURE ParmIsVar (idx, k : CARDINAL) : BOOLEAN ;
(* Is argument k (0-based) of procedure/function idx declared VAR?  Out of
   range means the source passed more arguments than there are formals; treat
   it as a value parameter, as ParmSlot already does. *)
VAR pi : CARDINAL ;
BEGIN
   IF (symtab [idx].parmCount = 0) OR (k >= symtab [idx].parmCount) THEN
      RETURN FALSE
   END ;
   pi := symtab [idx].parmFirst + k ;
   RETURN symtab [pi].isVar
END ParmIsVar ;

PROCEDURE EmCallMost (idx, cleanup : CARDINAL) ;
(* emit the call to sym 'idx' and clean up `cleanup' bytes of arguments, which
   is the SUM of their slot sizes - not 2 per argument once a slot can be
   larger than a word. *)
VAR p : CARDINAL ;
BEGIN
   EmitStaticLink (idx) ;
   IF symtab [idx].defnd THEN
      DropC (EmCall (symtab [idx].goPos))
   ELSE
      p := EmCall (0) ;
      AddPend (1, idx, p)
   END ;
   IF cleanup > 0 THEN
      EmAddSp (cleanup)
   END
END EmCallMost ;

PROCEDURE ParseCallArgs (idx : CARDINAL) ;
(* '(' already consumed: read args ')' then call.

   Each argument is loaded and pushed the moment it has been parsed, which is
   what TPSRC8 cproc/cprlp1/cprlp2 do - CALL exprsave, CALL epushax, one per
   argument, then the CALL.  A computed argument (kind 2) exists only in AX,
   so parsing the argument after it would destroy it before the push loop
   ever reached it: `p (a > b, x)' passed x twice.

   Pushing in parse order is also the order the callee is laid out for: the
   first argument goes on first and so ends up farthest from BP, and the LAST
   declared parameter is the one at BP+4 (RESUME-TP3.md 3.11). *)
VAR arg : ERes ;
    nArgs, cleanup, slot, nCopy : CARDINAL ;
BEGIN
   nArgs := 0 ;
   cleanup := 0 ;
   IF CurCh () = ')' THEN
      DropCh (GetCh ())
   ELSE
      LOOP
         IF nArgs >= 16 THEN
            Err (ECompOvf) ;
            EXIT
         END ;
         ParseExpr (arg) ;
         slot := ParmSlot (idx, nArgs) ;
         IF ParmIsVar (idx, nArgs) THEN
            (* VAR formal: push the actual's ADDRESS.  Only a variable has
               one; a constant or a computed value is refused rather than
               quietly passed by value.  An element with a constant index
               (`s[i]') is a variable too: its address is off+boff, which
               EmPushVarAddr forms directly. *)
            IF arg.kind = 5 THEN
               (* An element/field address already in DI, including a record
                  field passed as a VAR actual: Sheet[I,J].Contents. *)
               EmPushDi ()
            ELSIF arg.kind # 1 THEN
               Err (ENoLib) ;
               EXIT
            ELSIF symtab [arg.idx].isVar THEN
               (* Passing a VAR parameter on: its slot already HOLDS the
                  address, so push that, not the address of the slot. *)
               IF arg.boff # 0 THEN
                  Err (ENoLib) ;
                  EXIT
               END ;
               LoadSymVar (arg.idx, symtab [arg.idx].off, 2) ;
               EmPushAx ()
            ELSE
               EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H)
            END
         ELSIF slot > 2 THEN
            (* A STRING VALUE parameter: push its whole slot, copied.
               `copyN' is at most the slot: an actual shorter than the formal
               leaves the tail untouched, which is harmless because the length
               byte bounds every read. *)
            IF arg.cls = TString THEN
               nCopy := slot ;
               IF arg.kind = 1 THEN
                  IF VarSize (arg) < nCopy THEN
                     nCopy := VarSize (arg)
                  END
               ELSIF arg.kind = 3 THEN
                  IF strLen [arg.strx] + 1 < nCopy THEN
                     nCopy := strLen [arg.strx] + 1
                  END
               ELSE
                  Err (ENoLib) ;          (* a computed string is not a value *)
                  EXIT
               END ;
               EmPushStrSlot (arg, slot, nCopy)
            ELSIF arg.cls = TReal THEN
               EmPushRealSlot (arg, slot)
            ELSE
               Err (ETypeErr) ;
               EXIT
            END
         ELSE
            LoadAtom (arg) ;
            EmPushAx ()
         END ;
         cleanup := cleanup + slot ;
         INC (nArgs) ;
         IF NOT MatchDelim (',') THEN
            EXIT
         END
      END ;
      ExpectDelim (')', ENoSemi)
   END ;
   EmCallMost (idx, cleanup)
END ParseCallArgs ;

PROCEDURE ParseCall (idx : CARDINAL) ;
(* procedure/function call; '(' optional - same parse-then-push as above,
   reached from ParseAtom when a FUNCTION is called in an expression *)
VAR arg : ERes ;
    nArgs, cleanup, slot, nCopy : CARDINAL ;
BEGIN
   nArgs := 0 ;
   cleanup := 0 ;
   IF MatchDelim ('(') THEN
      IF CurCh () # ')' THEN
         LOOP
            IF nArgs >= 16 THEN
               Err (ECompOvf) ;
               EXIT
            END ;
            ParseExpr (arg) ;
            slot := ParmSlot (idx, nArgs) ;
            IF ParmIsVar (idx, nArgs) THEN
               (* A VAR formal in a FUNCTION call: the callee wants the
                  address, exactly as ParseCallArgs does for a procedure.  This
                  path was missing, so `Length(s)' inside a function whose
                  formal is `var s' pushed the string's VALUE and the callee
                  would have read it as an address. *)
               IF arg.kind = 5 THEN
                  EmPushDi ()
               ELSIF arg.kind # 1 THEN
                  Err (ENoLib) ;
                  EXIT
               ELSIF symtab [arg.idx].isVar THEN
                  IF arg.boff # 0 THEN
                     Err (ENoLib) ;
                     EXIT
                  END ;
                  LoadSymVar (arg.idx, symtab [arg.idx].off, 2) ;
                  EmPushAx ()
               ELSE
                  EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H)
               END
            ELSIF slot > 2 THEN
               (* see ParseCallArgs: push the whole string slot *)
               IF arg.cls = TString THEN
                  nCopy := slot ;
                  IF arg.kind = 1 THEN
                     IF VarSize (arg) < nCopy THEN
                        nCopy := VarSize (arg)
                     END
                  ELSIF arg.kind = 3 THEN
                     IF strLen [arg.strx] + 1 < nCopy THEN
                        nCopy := strLen [arg.strx] + 1
                     END
                  ELSE
                     Err (ENoLib) ;
                     EXIT
                  END ;
                  EmPushStrSlot (arg, slot, nCopy)
               ELSIF arg.cls = TReal THEN
                  EmPushRealSlot (arg, slot)
               ELSE
                  Err (ETypeErr) ;
                  EXIT
               END
            ELSE
               LoadAtom (arg) ;
               EmPushAx ()
            END ;
            cleanup := cleanup + slot ;
            INC (nArgs) ;
            IF NOT MatchDelim (',') THEN
               EXIT
            END
         END ;
         ExpectDelim (')', ENoSemi)
      ELSE
         DropCh (GetCh ())
      END
   END ;
   callScratch := 0 ;
   IF symtab [idx].cls = TReal THEN
      callScratch := NewScratchReal () ;
      EmLeaDi (FALSE, symtab [callScratch].off)
   END ;
   EmCallMost (idx, cleanup)
END ParseCall ;

PROCEDURE ParseExpr (VAR r : ERes) ;
BEGIN
   ParseCmp (r)
END ParseExpr ;

(* ---------------------------------------------------------------- *)
(*  statements  (TPSRC8)                                            *)
(* ---------------------------------------------------------------- *)

PROCEDURE IntToMbf (v : LONGINT ; VAR b : ARRAY OF CHAR) ;
(* TP3's 6-byte Real, as measured in CALC-PORT.md against the cells holding
   1, 2, 3, 4 and 5:

      value = (1 + N / 2^39) * 2^(E - 129)

   byte 0 is E (biased by 129); bytes 1..5 are N, little-endian; the SIGN is
   bit 7 of byte 5 (the book's `sign + 39-bit mantissa').  An all-zero value
   is 0.0.  1 -> 81 00 00 00 00 00, 3 -> 82 00 00 00 00 40,
   5 -> 83 00 00 00 00 20 - all cross-checked against CALCDEMO.MCS.

   Only INTEGER values are converted; real arithmetic and formatting are a
   later stage, and a real RHS that is not a constant or a copy is ENoLib. *)
VAR a, p, n : LONGINT ;
    e, k, i : CARDINAL ;
    neg : BOOLEAN ;
BEGIN
   i := 0 ;
   WHILE i < 6 DO
      b [i] := CHR (0) ;
      INC (i)
   END ;
   (* The parser represents a negated 16-bit INTEGER constant as its
      unsigned 16-bit bit pattern (W16), so -1 arrives as 65535.  Convert that
      back to a signed value before building a REAL; otherwise `R := -1' would
      become +65535. *)
   IF (v > 32767) AND (v <= 65535) THEN
      v := v - 65536
   END ;
   IF v = 0 THEN
      RETURN
   END ;
   neg := v < 0 ;
   IF neg THEN
      a := -v
   ELSE
      a := v
   END ;
   (* k = floor(log2(a)); p = 2^k *)
   p := 1 ;
   k := 0 ;
   WHILE (k < 39) AND (p * 2 <= a) DO
      p := p * 2 ;
      INC (k)
   END ;
   IF k >= 39 THEN
      Err (EConstRange) ;
      RETURN
   END ;
   e := 129 + k ;
   b [0] := CHR (e) ;
   n := a - p ;
   i := 39 - k ;
   WHILE i > 0 DO
      n := n * 2 ;
      DEC (i)
   END ;
   i := 1 ;
   WHILE i <= 5 DO
      b [i] := CHR (VAL (CARDINAL, n MOD 256)) ;
      n := n DIV 256 ;
      INC (i)
   END ;
   IF neg THEN
      b [5] := CHR (ORD (b [5]) + 128)
   END
END IntToMbf ;

PROCEDURE RealOperand (r : ERes ; dstOff : CARDINAL) ;
(* Copy a REAL operand into a 6-byte scratch, converting an ordinal value to
   REAL first.  RealBin and RealUnary used to call EmCopyRealTo directly; an
   INTEGER variable there was refused, so `E := A/B' could not compile. *)
VAR tmp : CARDINAL ;
BEGIN
   IF r.cls = TReal THEN
      EmCopyRealTo (dstOff, r)
   ELSIF (r.cls = TSet) OR (r.cls = TString) THEN
      Err (ETypeErr)
   ELSE
      IF r.kind = 5 THEN
         EmPushDi ()
      ELSIF r.kind = 1 THEN
         EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
      ELSE
         LoadAtom (r) ;
         EmStoreVar (FALSE, symtab [tmpA].off, 2) ;
         EmPushVarAddr (FALSE, symtab [tmpA].off)
      END ;
      EmPushVarAddr (FALSE, dstOff) ;
      DropC (EmCall (TU_RealFromInt)) ;
      EmAddSp (4)
   END
END RealOperand ;

PROCEDURE RealBin (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ;
(* REAL + - * / using the runtime's 12-byte block entries.  SaveLeft has
   already copied a REAL left operand to a stable scratch; a kind-5 right is
   copied first, while its DI address is live. *)
VAR block, ent : CARDINAL ;
BEGIN
   block := NewScratchRealBlock () ;
   IF right.kind = 5 THEN
      RealOperand (right, symtab [block].off + 6) ;
      RealOperand (left, symtab [block].off)
   ELSE
      RealOperand (left, symtab [block].off) ;
      RealOperand (right, symtab [block].off + 6)
   END ;
   CASE op OF
      OpAdd : ent := TU_RealAdd
   |  OpSub : ent := TU_RealSub
   |  OpMul : ent := TU_RealMul
   |  OpDiv : ent := TU_RealDiv
   ELSE
      Err (ETypeErr) ;
      RETURN
   END ;
   EmPushVarAddr (FALSE, symtab [block].off) ;
   DropC (EmCall (ent)) ;
   EmAddSp (2) ;
   res.kind := 1 ;
   res.idx := block ;
   res.cls := TReal ;
   res.sz := 6 ;
   res.boff := 0
END RealBin ;

PROCEDURE RealUnary (ent : CARDINAL ; VAR r : ERes) ;
(* A one-argument REAL builtin: copy the operand into a 12-byte block and let
   the runtime entry leave its result in the first six bytes. *)
VAR block : CARDINAL ;
BEGIN
   block := NewScratchRealBlock () ;
   EmCopyRealTo (symtab [block].off, r) ;
   EmPushVarAddr (FALSE, symtab [block].off) ;
   DropC (EmCall (ent)) ;
   EmAddSp (2) ;
   r.kind := 1 ;
   r.idx := block ;
   r.cls := TReal ;
   r.sz := 6 ;
   r.boff := 0
END RealUnary ;

END CompilerExpr.