TP3/shell/Compiler.mod

IMPLEMENTATION MODULE Compiler ;

(* Turbo Pascal 3-style single-pass Pascal -> 8086 compiler in
   GNU Modula-2 (-fiso), following the structure of the original
   TPSRC6 'turbo' entry / TPSRC7-10:

     Inittur      reset state, pre-defined types, scratch temporaries
     Skip         lexer: blanks, comments { } and (* *), directives {$ }
     GetWord/WddTok/MatchKey  word lexing with a keyword table (kName/kTk)
     PeekKw       lookahead keyword check WITHOUT consuming (via saved
                  srcPos) - needed because declarations and compound
                  statements peek at END/ELSE/etc
     RdIntConst/RdConst  integer, hex and char constants
     Search       symbol table lookup filtered by lexical level
     ParseExpr -> ParseCmp -> ParseAdd -> ParseMul -> ParseNeg
                  -> ParseAtom   precedence climb (TPSRC9)
     Statmnt     statements: if/while/repeat/for/case/goto/exit/begin
                  assignment and calls (TPSRC8)
     ParseType/Decls  ARRAY, STRING, scalar/subrange types; variable,
                  constant, label and procedure/function definitions
     Compile      driver: optional PROGRAM header, DefPart, progpart,
                  final '.', header size patch, patch resolution.
     Ebyte/Eword/Ecall/Ejmp + patch list  code emission (TPSRC10).

   The emitted image is a byte array (mode word, CS/DS, size words,
   CALL initmem, MOV BP,SP, then generated code).  Forward labels and
   forward procedure calls resolve through a patch list (ptc records).

   Working subset (v0.4): integer/char/boolean/byte scalars, constants
   with folding, globals, locals, value parameters, procedures and
   scalar-result functions, ARRAY[const..const] with constant indexing,
   control flow, GOTO/EXIT, and the standard procedures WRITE, WRITELN,
   READ, READLN, HALT (DefBuiltins + IoCall).

   The standard procedures are dispatched per argument, as the original
   does (TPSRC8 pwriteln/pwrloop inspects each argument's class and emits
   a different call per type), so the runtime is handed a value and never
   a descriptor.

   Still not implemented: real/set/record/file and the string runtime
   raise Err (ENoLib) - the original's "not implemented" path.  The
   runtime blob itself, the linker that rebases the TU_* entry offsets
   by the runtime's size, and CmdRun (the interpreter) are still pending,
   so a compiled image cannot be executed yet. *)

FROM TextBuf IMPORT TextLimit, Length, CharAt, InsertStr, DeleteFromTo ;

FROM SYSTEM IMPORT BYTE, ADR ;

FROM Posix IMPORT open, read, close ;

FROM Runtime IMPORT RT_Build, RT_Size, RT_Byte, RT_Entry, LoadBias ;
(* The runtime is copied to the front of the code buffer and pc/dc start past
   it, so every emitted address is image-absolute and no relocation pass is
   needed.  See Inittur.

   `LoadBias' comes from Runtime because it is the same constant on both
   sides of the image: Runtime adds it to every data address it bakes into its
   own code (FixUp, kind 2), and this module adds it to every ABSOLUTE address
   it bakes into the program's.  It is deliberately ONE constant in ONE place
   rather than 0100h written out at six sites, because getting it wrong at one
   site is invisible - see the note on LoadBias in Runtime.mod.  Relative
   encodings (the entry JMP, every CALL and JMP) must NOT get it: both
   operands shift together and the +0100h cancels. *)

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 Ebyte, Eword, PatchWord, AddPatch, SetPatTgt, EmCall, EmJmpNear, JccShort, JccShortInv, EmJcc, ResolvePatches, EmMovAxi, EmMovCxi, EmMovBpSp, EmMovAh0, EmMovAxSp, EmMovCxSp, EmPushAx, EmPopCx, EmPopDx, EmPopSi, EmPopAx, EmPushBx, EmPushCx, EmPushDx, EmPopBx, EmMovAxCx, EmMovChAl, EmMovChImm, EmXchgAxCx, EmXorAxAx, EmAddAxCx, EmSubAxCx, EmMulAxCx, EmIDivAxCx, EmAndAxCx, EmOrAxCx, EmOrAxAx, EmNegAx, EmNotAx, EmXorAl01, EmCmpAxCx, EmCmpAxi, EmSetcc, EmRelSetcc, EmIncAx, EmDecAx, EmBpDisp, EmBxDisp, EmMovBxBp, EmMovDxBp, EmMovDxBx, EmMovDxAx, EmMovAxDx, EmLdBxBx, EmLoadVarBx, EmStoreVarBx, EmLeaDiBx ;

FROM CompilerSource IMPORT CurCh, GetCh, PeekAhead, Upper, SetSourcePath, ExpandIncludes, srcLen, inclActive, inclEnd ;
FROM CompilerUtil IMPORT Digit, Alpha, AlphaNum, IsHexCh, W16, DropCh,
                          DropB, DropC, BitAnd, BitOr, BitNot, NameEq,
                          CopyStr, NumToName ;
FROM CompilerSymbols IMPORT SymEntry, symtab, symTop, lexnest, wrd,
                             NewSym, Search, DupTest, HideLocals,
                             CopyWord, SaveWord ;
FROM CompilerLex IMPORT InitKeys, IsBlank, Skip, GetWord, WddTok,
                          DeclaresProc, KwAhead, PeekKw, MatchKey,
                          MatchDelim, MatchAssign, MatchRange, ExpectDelim,
                          HexVal, RdIntConst, StrNew, StrPut, RdConst,
                          strPool, strOff, strLen, strTop, strCnt, rdStrX ;
FROM CompilerIO IMPORT IoCall ;
FROM CompilerExpr IMPORT AddPend, AllocSetScratch, BinOpEmit, ConstAdd,
                          ConstCmp, ConstMul, ConstSub, EmAsciiZLiteral,
                          EmCallMost, EmCopyRealTo, EmPushRealAddr,
                          EmPushRealSlot, EmPushSetAddr, EmPushStrAddr,
                          EmPushStrOperand, EmPushStrSlot, EmSetBlob,
                          EmStrBlob, EmXchgAxDx, EmitBoundsCheck, FoldSetIn,
                          IntToMbf, IsCharArray, LoadAtom, LoadPair,
                          MaterializeDyn, NewScratchReal,
                          NewScratchRealBlock, NewScratchStr, NewScratchWord,
                          ParmIsVar, ParmSlot, ParseAdd, ParseAtom,
                          ParseCall, ParseCallArgs, ParseCmp, ParseExpr,
                          ParseMul, ParseNeg, ParseSub,
                          ParseVar, RdSetBase, RdSetLiteral, RealBin,
                          RealOperand, RealUnary, SaveLeft, SetBinEmit,
                          SetPairSize, SetRangeBits, StrConcat, StrOperand,
                          VarSize, WithLookup ;

(* ---------------------------------------------------------------- *)
(*  constants                                                       *)
(* ---------------------------------------------------------------- *)

(* ---------------------------------------------------------------- *)
(*  small char helpers                                              *)
(* ---------------------------------------------------------------- *)

(* ---------------------------------------------------------------- *)
(*  errors                                                          *)
(* ---------------------------------------------------------------- *)

(* ---------------------------------------------------------------- *)
(*  {$I file} include                                               *)
(* ---------------------------------------------------------------- *)

PROCEDURE SetSource (path : ARRAY OF CHAR) ;
(* Public name kept for Shell/Linker; the source module owns the directory
   string used by {$I file} resolution. *)
BEGIN
   SetSourcePath (path)
END SetSource ;

PROCEDURE EmLoadVar (local : BOOLEAN ; off, nbytes : CARDINAL) ;
(* A local is [BP+off] and `off' is already a frame displacement, so it needs
   no bias.  A global is [off] with a DIRECT displacement, i.e. an absolute
   address, and that is the image offset + LoadBias - see Runtime.LoadBias. *)
BEGIN
   IF nbytes = 1 THEN
      IF local THEN
         Ebyte (8AH) ; EmBpDisp (off, 0)
      ELSE
         Ebyte (0A0H) ; Eword ((off + LoadBias) MOD 10000H)
      END
   ELSE
      IF local THEN
         Ebyte (8BH) ; EmBpDisp (off, 0)
      ELSE
         Ebyte (0A1H) ; Eword ((off + LoadBias) MOD 10000H)
      END
   END
END EmLoadVar ;

PROCEDURE EmXorByteGlob (off, v : CARDINAL) ;
BEGIN Ebyte (80H) ; Ebyte (36H) ; Eword ((off + LoadBias) MOD 10000H) ;
      Ebyte (VAL (BYTE, v)) END EmXorByteGlob ;

PROCEDURE EmStoreVar (local : BOOLEAN ; off, nbytes : CARDINAL) ;
BEGIN
   IF nbytes = 1 THEN
      IF local THEN
         Ebyte (88H) ; EmBpDisp (off, 0)
      ELSE
         Ebyte (0A2H) ; Eword ((off + LoadBias) MOD 10000H)
      END
   ELSE
      IF local THEN
         Ebyte (89H) ; EmBpDisp (off, 0)
      ELSE
         Ebyte (0A3H) ; Eword ((off + LoadBias) MOD 10000H)
      END
   END
END EmStoreVar ;

PROCEDURE EmPushVarAddr (local : BOOLEAN ; off : CARDINAL) ;
(* LEA AX,[BP+disp] / LEA AX,[off] then PUSH AX - READ passes the address of
   a variable, not its value.  8D 46 disp is LEA AX,[BP+disp8] and
   8D 86 lo hi is LEA AX,[BP+disp16]; 8D 06 off is LEA AX,[off]
   (mod=00 rm=110 = the direct disp16 form).  All three are 8086-legal.
   The [off] form is absolute and so carries LoadBias; the [BP+disp] forms
   are displacements and so do not. *)
BEGIN
   IF local THEN
      Ebyte (8DH) ; EmBpDisp (off, 0)
   ELSE
      Ebyte (8DH) ; Ebyte (06H) ; Eword ((off + LoadBias) MOD 10000H)
   END ;
   EmPushAx ()
END EmPushVarAddr ;

PROCEDURE EmLeaDi (local : BOOLEAN ; off : CARDINAL) ;
(* LEA DI,[BP+disp] / LEA DI,[off] - the run-time address of an indexed
   string's element, computed once in ParseSub and read by LoadAtom,
   Assignment and IoCall.

   It is the same three encodings EmPushVarAddr uses for AX - 8D 7E disp8,
   8D BE disp16, 8D 3E off - with the ModR/M reg field set to DI (111)
   instead of the accumulator, which is why EmBpDisp now takes that field and
   this is still the one place the disp8/disp16 choice is made.  A local is
   [BP+disp] with no bias; a global is [off] and carries LoadBias, absolute.

   The later `MOV AL,[DI]` / `MOV [DI],AL` read through DS rather than SS.
   That is correct here for the same reason TP3's own string ops use DI with
   the default segment: a .COM loads with DS=SS=CS=ES, and nothing in this
   compiler or its runtime ever reloads a segment register, so a BP-relative
   frame address held in DI addresses the same byte. *)
BEGIN
   IF local THEN
      Ebyte (8DH) ; EmBpDisp (off, 7)
   ELSE
      Ebyte (8DH) ; Ebyte (3EH) ; Eword ((off + LoadBias) MOD 10000H)
   END
END EmLeaDi ;

PROCEDURE EmMovBxAx () ;
BEGIN Ebyte (89H) ; Ebyte (0C3H) END EmMovBxAx ;   (* MOV BX,AX *)

PROCEDURE EmitFrameBase (level : CARDINAL) ;
(* Leave BX pointing at the frame for lexical scope `level', pushing the old
   BX.  The current frame is at `lexnest'; each step follows the hidden
   static link stored by the enclosing procedure.  The caller must POP BX
   after the access. *)
VAR p, k : CARDINAL ;
BEGIN
   EmPushBx () ;
   EmMovBxBp () ;
   p := curProc ;
   k := lexnest ;
   WHILE k > level DO
      EmLdBxBx (symtab [p].staticOff) ;
      p := symtab [p].parent ;
      DEC (k)
   END
END EmitFrameBase ;

PROCEDURE IsOuterLocal (idx : CARDINAL) : BOOLEAN ;
BEGIN
   RETURN symtab [idx].local AND (symtab [idx].level < lexnest)
END IsOuterLocal ;

PROCEDURE LoadSymVar (idx, off, nbytes : CARDINAL) ;
BEGIN
   IF IsOuterLocal (idx) THEN
      EmitFrameBase (symtab [idx].level) ;
      EmLoadVarBx (off, nbytes) ;
      EmPopBx ()
   ELSE
      EmLoadVar (symtab [idx].local, off, nbytes)
   END
END LoadSymVar ;

PROCEDURE StoreSymVar (idx, off, nbytes : CARDINAL) ;
BEGIN
   IF IsOuterLocal (idx) THEN
      EmitFrameBase (symtab [idx].level) ;
      EmStoreVarBx (off, nbytes) ;
      EmPopBx ()
   ELSE
      EmStoreVar (symtab [idx].local, off, nbytes)
   END
END StoreSymVar ;

PROCEDURE EmPushSymAddr (idx, off : CARDINAL) ;
BEGIN
   IF IsOuterLocal (idx) THEN
      EmitFrameBase (symtab [idx].level) ;
      Ebyte (8DH) ; EmBxDisp (off, 0) ;   (* LEA AX,[BX+off] *)
      EmPopBx () ;                        (* restore BX before pushing AX *)
      EmPushAx ()
   ELSE
      EmPushVarAddr (symtab [idx].local, off)
   END
END EmPushSymAddr ;

PROCEDURE LeaDiSym (idx, off : CARDINAL) ;
BEGIN
   IF IsOuterLocal (idx) THEN
      EmitFrameBase (symtab [idx].level) ;
      EmLeaDiBx (off) ;
      EmPopBx ()
   ELSE
      EmLeaDi (symtab [idx].local, off)
   END
END LeaDiSym ;

PROCEDURE EmLoadVarIndSym (idx, nbytes : CARDINAL) ;
(* AX := the value reached through a VAR parameter's address slot. *)
BEGIN
   LoadSymVar (idx, symtab [idx].off, 2) ;
   EmMovBxAx () ;
   IF nbytes = 1 THEN
      Ebyte (8AH) ; Ebyte (07H) ;
      EmMovAh0 ()
   ELSE
      Ebyte (8BH) ; Ebyte (07H)
   END
END EmLoadVarIndSym ;

PROCEDURE StoreVarIndPrepSym (idx : CARDINAL) ;
(* DI := the address held by a VAR parameter's slot, then PUSH DI. *)
BEGIN
   LoadSymVar (idx, symtab [idx].off, 2) ;
   EmMovDiAx () ;
   EmPushDi ()
END StoreVarIndPrepSym ;

PROCEDURE EmitStaticLink (idx : CARDINAL) ;
(* Pass the lexical parent frame in DX before a call to a nested procedure.
   The callee saves it in its hidden static-link local.  A top-level procedure
   has no parent frame and gets nothing. *)
VAR level : CARDINAL ;
BEGIN
   level := symtab [idx].level ;
   IF level = 0 THEN
      RETURN
   END ;
   IF level = lexnest THEN
      EmMovDxBp ()
   ELSE
      EmitFrameBase (level) ;
      EmMovDxBx () ;
      EmPopBx ()
   END
END EmitStaticLink ;

PROCEDURE EmAddDiAx () ;
BEGIN Ebyte (01H) ; Ebyte (0C7H) END EmAddDiAx ;  (* 01 C7: DI := DI + AX *)

PROCEDURE EmAddDiImm (n : CARDINAL) ;
(* ADD DI,imm16: a record field's offset when the element's address is already
   in DI (`Sheet[I,J].Field', `with Sheet[I,J] do'). *)
BEGIN
   Ebyte (81H) ; Ebyte (0C7H) ; Eword (n MOD 10000H)
END EmAddDiImm ;

PROCEDURE EmLdDiGlob (off : CARDINAL) ;
(* MOV DI,[off]: recover the base address WITH saved in a scratch word.  The
   body of a WITH may clobber DI, so the address is parked in the data area
   and reloaded for every field access. *)
BEGIN
   Ebyte (8BH) ; Ebyte (3EH) ; Eword ((off + LoadBias) MOD 10000H)
END EmLdDiGlob ;

PROCEDURE EmStDiGlob (off : CARDINAL) ;
(* MOV [off],DI: the WITH statement's base-address scratch. *)
BEGIN
   Ebyte (89H) ; Ebyte (3EH) ; Eword ((off + LoadBias) MOD 10000H)
END EmStDiGlob ;

PROCEDURE EmLdAlDi () ;
BEGIN Ebyte (8AH) ; Ebyte (05H) END EmLdAlDi ;    (* 8A 05: AL := [DI] *)

PROCEDURE EmLdAlSi () ;
BEGIN Ebyte (8AH) ; Ebyte (04H) END EmLdAlSi ;    (* 8A 04: AL := [SI] *)

PROCEDURE EmIncSi () ;
BEGIN Ebyte (46H) END EmIncSi ;

PROCEDURE EmIncDi () ;
BEGIN Ebyte (47H) END EmIncDi ;

PROCEDURE EmMovDiAx () ;
BEGIN Ebyte (89H) ; Ebyte (0C7H) END EmMovDiAx ;  (* 89 C7: DI := AX *)

PROCEDURE EmMovAxDi () ;
BEGIN Ebyte (89H) ; Ebyte (0F8H) END EmMovAxDi ;  (* 89 F8: AX := DI *)

PROCEDURE EmLdAxDi () ;
BEGIN Ebyte (8BH) ; Ebyte (05H) END EmLdAxDi ;    (* 8B 05: AX := [DI] *)

PROCEDURE EmStDiAl () ;
BEGIN Ebyte (88H) ; Ebyte (05H) END EmStDiAl ;    (* 88 05: [DI] := AL *)

PROCEDURE EmPushDi () ;
BEGIN Ebyte (57H) END EmPushDi ;                  (* PUSH DI *)

PROCEDURE EmPushSi () ;
BEGIN Ebyte (56H) END EmPushSi ;                  (* PUSH SI *)

PROCEDURE EmMovAxDs () ;
BEGIN Ebyte (8CH) ; Ebyte (0D8H) END EmMovAxDs ;  (* MOV AX,DS *)

PROCEDURE EmPopDi () ;
BEGIN Ebyte (5FH) END EmPopDi ;                   (* POP DI *)

PROCEDURE EmLoadVarInd (off, nbytes : CARDINAL) ;
(* AX := the value of a VAR parameter.  [BP+off] holds the ADDRESS; BX carries
   it so the byte/word load has a base register.  The address is a DS offset:
   a .COM has one segment, which is why no segment register appears here. *)
BEGIN
   EmLoadVar (TRUE, off, 2) ;        (* AX := [BP+off], the address *)
   Ebyte (89H) ; Ebyte (0C3H) ;      (* MOV BX,AX *)
   IF nbytes = 1 THEN
      Ebyte (8AH) ; Ebyte (07H) ;    (* MOV AL,[BX] *)
      EmMovAh0 ()
   ELSE
      Ebyte (8BH) ; Ebyte (07H)      (* MOV AX,[BX] *)
   END
END EmLoadVarInd ;

PROCEDURE EmStoreVarIndPrep (off : CARDINAL) ;
(* DI := the address of a VAR parameter, then PUSH DI.  The push protects it
   across the parse of the right-hand side, which may use DI for a string
   element of its own.  EmStoreInd finishes the store after POP DI. *)
BEGIN
   Ebyte (8BH) ; EmBpDisp (off, 7) ; (* MOV DI,[BP+off] *)
   EmPushDi ()
END EmStoreVarIndPrep ;

PROCEDURE EmStDiImm (off, v : CARDINAL) ;
(* MOV byte [DI+off],imm8: one byte of a set constructor stored through a
   DI-addressed record field.  Sets are at most 32 bytes, so disp8 is enough. *)
BEGIN
   Ebyte (0C6H) ; Ebyte (45H) ; Ebyte (VAL (BYTE, off)) ; Ebyte (VAL (BYTE, v))
END EmStDiImm ;

PROCEDURE EmStDiAlOff (off : CARDINAL) ;
(* MOV [DI+off],AL: one byte of a real copied through a DI-addressed field. *)
BEGIN
   Ebyte (88H) ; Ebyte (45H) ; Ebyte (VAL (BYTE, off))
END EmStDiAlOff ;

PROCEDURE EmLdAlDiOff (off : CARDINAL) ;
(* MOV AL,[DI+off]: the byte of a set variable that holds an element's bit. *)
BEGIN
   Ebyte (8AH) ; Ebyte (45H) ; Ebyte (VAL (BYTE, off))
END EmLdAlDiOff ;

PROCEDURE EmCmpAlImm (v : CARDINAL) ;
BEGIN Ebyte (3CH) ; Ebyte (VAL (BYTE, v)) END EmCmpAlImm ;  (* CMP AL,imm8 *)

PROCEDURE EmSubAlImm (v : CARDINAL) ;
BEGIN Ebyte (2CH) ; Ebyte (VAL (BYTE, v)) END EmSubAlImm ;  (* SUB AL,imm8 *)

PROCEDURE EmMovClAl () ;
BEGIN Ebyte (88H) ; Ebyte (0C1H) END EmMovClAl ;        (* MOV CL,AL *)

PROCEDURE EmAndClImm (v : CARDINAL) ;
BEGIN Ebyte (80H) ; Ebyte (0E1H) ; Ebyte (VAL (BYTE, v)) END EmAndClImm ;

PROCEDURE EmShrAx1 () ;
BEGIN Ebyte (0D1H) ; Ebyte (0E8H) END EmShrAx1 ;        (* SHR AX,1 *)

PROCEDURE EmShlAxCl () ;
BEGIN Ebyte (0D3H) ; Ebyte (0E0H) END EmShlAxCl ;       (* SHL AX,CL *)

PROCEDURE EmShrAxCl () ;
BEGIN Ebyte (0D3H) ; Ebyte (0E8H) END EmShrAxCl ;       (* SHR AX,CL *)

PROCEDURE EmMovBxi (v : CARDINAL) ;
BEGIN Ebyte (0BBH) ; Eword (v MOD 10000H) END EmMovBxi ; (* MOV BX,imm16 *)

PROCEDURE EmLeaBx (off : CARDINAL) ;
(* LEA BX,[BP+off]: the address of a local set. *)
BEGIN
   Ebyte (8DH) ; EmBpDisp (off, 3)
END EmLeaBx ;

PROCEDURE EmMovBxDi () ;
BEGIN Ebyte (89H) ; Ebyte (0FBH) END EmMovBxDi ;        (* MOV BX,DI *)

PROCEDURE EmAddBxAx () ;
BEGIN Ebyte (01H) ; Ebyte (0C3H) END EmAddBxAx ;        (* ADD BX,AX *)

PROCEDURE EmLdAlBx () ;
BEGIN Ebyte (8AH) ; Ebyte (07H) END EmLdAlBx ;         (* MOV AL,[BX] *)

PROCEDURE EmMovDlImm (v : CARDINAL) ;
BEGIN Ebyte (0B2H) ; Ebyte (VAL (BYTE, v)) END EmMovDlImm ;

PROCEDURE EmShlDlCl () ;
BEGIN Ebyte (0D2H) ; Ebyte (0E2H) END EmShlDlCl ;       (* SHL DL,CL *)

PROCEDURE EmAndAlDl () ;
BEGIN Ebyte (20H) ; Ebyte (0D0H) END EmAndAlDl ;        (* AND AL,DL *)

PROCEDURE EmAndAlImm (v : CARDINAL) ;
BEGIN Ebyte (24H) ; Ebyte (VAL (BYTE, v)) END EmAndAlImm ;  (* AND AL,imm8 *)

PROCEDURE EmStoreInd (nbytes : CARDINAL) ;
(* [DI] := AL/WORD, after POP DI - the companion of EmStoreVarIndPrep. *)
BEGIN
   IF nbytes = 1 THEN
      EmStDiAl ()                     (* MOV [DI],AL *)
   ELSE
      Ebyte (89H) ; Ebyte (05H)       (* MOV [DI],AX *)
   END
END EmStoreInd ;

PROCEDURE EmFileIo (reading : BOOLEAN ; fileLocal : BOOLEAN ; fileOff : CARDINAL ;
                    addrKind : CARDINAL ; addrLocal : BOOLEAN ;
                    addrOff, count : CARDINAL ; stringArg : BOOLEAN) ;
(* Typed-file block I/O: read/write `count' bytes at the data argument to the
   open file in the file variable.

   ABI to DOS: BX = handle, CX = byte count, DS:DX = buffer, AH = 3Fh read /
   40h write.  The handle is the first word of the file control block.  For a
   DI-addressed record (`Sheet[I,J]') the address is already in DI; a plain
   variable's address is formed by LEA.  The DOS result is handed to the
   io_store runtime entry, so IOResult sees it.

   This is emitted directly rather than through a runtime entry because the
   runtime has only ~45 bytes of probe headroom left; the code is two words
   per call site and the compiler's code budget is the loose one. *)
BEGIN
   IF addrKind = 5 THEN
      (* DI already holds a kind-5 element's address. *)
   ELSIF addrKind = 4 THEN
      EmLeaDi (FALSE, addrOff)           (* a code-resident blob *)
   ELSIF addrKind = 1 THEN
      EmLeaDi (addrLocal, addrOff)
   ELSE
      Err (ETypeErr) ;
      RETURN
   END ;
   Ebyte (89H) ; Ebyte (0FAH) ;          (* MOV DX,DI *)
   IF stringArg THEN
      (* DX points at the characters, CX = the length byte at [DI]. *)
      Ebyte (42H) ;                      (* INC DX *)
      EmLdAlDi () ;
      EmMovClAl () ;
      Ebyte (30H) ; Ebyte (0EDH)         (* XOR CH,CH *)
   ELSE
      EmMovCxi (count)
   END ;
   EmLoadVar (fileLocal, fileOff, 2) ;   (* AX := the DOS handle *)
   Ebyte (89H) ; Ebyte (0C3H) ;          (* MOV BX,AX *)
   Ebyte (0B4H) ;                        (* MOV AH,3Fh/40h *)
   IF reading THEN Ebyte (3FH) ELSE Ebyte (40H) END ;
   Ebyte (0CDH) ; Ebyte (21H) ;          (* INT 21h *)
   DropC (EmCall (TU_IoStore))
END EmFileIo ;

PROCEDURE EmInlineCh (ch : CARDINAL) : CARDINAL ;
(* Emit a one-character string literal behind a JMP and return the image
   offset of its length byte.  Used by text-file Write(File, ' '). *)
VAR here : CARDINAL ;
BEGIN
   Ebyte (0EBH) ; Ebyte (2) ;
   here := pc ;
   Ebyte (1) ; Ebyte (VAL (BYTE, ch)) ;
   RETURN here
END EmInlineCh ;

PROCEDURE EmInlineCrLf () : CARDINAL ;
(* The CR LF pair every text-file Writeln emits. *)
VAR here : CARDINAL ;
BEGIN
   Ebyte (0EBH) ; Ebyte (3) ;
   here := pc ;
   Ebyte (2) ; Ebyte (13) ; Ebyte (10) ;
   RETURN here
END EmInlineCrLf ;

PROCEDURE EmSubSp (n : CARDINAL) ;
BEGIN
   Ebyte (81H) ; Ebyte (0ECH) ; Eword (n MOD 10000H)
END EmSubSp ;

PROCEDURE EmAddSp (n : CARDINAL) ;
BEGIN
   IF n <= 126 THEN
      Ebyte (83H) ; Ebyte (0C4H) ; Ebyte (VAL (BYTE, n))
   ELSE
      Ebyte (81H) ; Ebyte (0C4H) ; Eword (n MOD 10000H)
   END
END EmAddSp ;

PROCEDURE EmPushBp () ;
BEGIN
   Ebyte (55H)
END EmPushBp ;

PROCEDURE EmLeave () ;
BEGIN
   Ebyte (0C9H)
END EmLeave ;

PROCEDURE EmRet () ;
BEGIN
   Ebyte (0C3H)
END EmRet ;

(* ---------------------------------------------------------------- *)
(*  symbol table                                                    *)
(* ---------------------------------------------------------------- *)

(* ---------------------------------------------------------------- *)
(*  lexer                                                           *)
(* ---------------------------------------------------------------- *)

(* ---------------------------------------------------------------- *)
(*  forward declarations                                            *)
(* ---------------------------------------------------------------- *)

PROCEDURE ParseType (VAR cls, size, elem : CARDINAL) ; FORWARD ;
PROCEDURE Statmnt () ; FORWARD ;
PROCEDURE SlotSize (cls, size : CARDINAL) : CARDINAL ; FORWARD ;
PROCEDURE ParamSlotBytes (e : SymEntry) : CARDINAL ; FORWARD ;
PROCEDURE ParseLabelStmt () ;
(* numeric or named label definition 'n :' / 'Name:' *)
VAR n : CARDINAL ;
    nm : ARRAY [0..MaxName] OF CHAR ;
    idx : CARDINAL ;
    i : CARDINAL ;
BEGIN
   IF Alpha (CurCh ()) THEN
      GetWord () ;
      SaveWord (nm)
   ELSE
      n := 0 ;
      WHILE Digit (CurCh ()) DO
         n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ;
         DropCh (GetCh ())
      END ;
      NumToName (n, nm)
   END ;
   ExpectDelim (':', ENoSemi) ;
   IF Search (nm, idx) THEN
      IF symtab [idx].tag = KLabel THEN
         symtab [idx].defnd := TRUE ;
         symtab [idx].goPos := pc ;
         i := 0 ;
         WHILE i < nPend DO
            IF (pend [i].kind = 0) AND (pend [i].who = idx) THEN
               SetPatTgt (pend [i].place, pc) ;
               pend [i].kind := 99
            END ;
            INC (i)
         END
      ELSE
         Err (EUnknown)
      END
   ELSE
      idx := NewSym (nm, KLabel, TScalar, 0, 0, 0, 0, FALSE) ;
      symtab [idx].defnd := TRUE ;
      symtab [idx].goPos := pc
   END
END ParseLabelStmt ;


PROCEDURE BoundsOf (r : ERes ; VAR lo, hi : CARDINAL) : BOOLEAN ;
(* Find a scalar/subrange bound for an assignment target.  Direct symbols use
   their SymEntry bounds; a record field is found by its byte offset. *)
VAR fi : CARDINAL ;
BEGIN
   lo := 0 ; hi := 0 ;
   IF r.hasBounds THEN
      lo := W16 (r.blo) ; hi := W16 (r.bhi) ;
      RETURN TRUE
   END ;
   IF r.kind # 1 THEN RETURN FALSE END ;
   IF symtab [r.idx].fldFirst < symtab [r.idx].fldLast THEN
      fi := symtab [r.idx].fldFirst ;
      WHILE fi < symtab [r.idx].fldLast DO
         IF fields [fi].off = r.boff THEN
            IF ((fields [fi].cls = TScalar) OR (fields [fi].cls = TEnum) OR
                (fields [fi].cls = TChar)) AND
               (fields [fi].lo # fields [fi].hi) THEN
               lo := W16 (fields [fi].lo) ; hi := W16 (fields [fi].hi) ;
               RETURN TRUE
            END ;
            RETURN FALSE
         END ;
         INC (fi)
      END ;
      RETURN FALSE
   END ;
   IF r.boff = 0 THEN
      IF ((r.cls = TScalar) OR (r.cls = TEnum) OR (r.cls = TChar)) AND
         (symtab [r.idx].lo # symtab [r.idx].hi) THEN
         lo := W16 (symtab [r.idx].lo) ; hi := W16 (symtab [r.idx].hi) ;
         RETURN TRUE
      END
   END ;
   RETURN FALSE
END BoundsOf ;

PROCEDURE Assignment (r : ERes) ;
(* ':=' already consumed by the caller; store expression into r *)
VAR src : ERes ;
    k, n, savePos, scratch, blo, bhi : CARDINAL ;
    sbuf : ARRAY [0..31] OF CHAR ;
    rbuf : ARRAY [0..5] OF CHAR ;
BEGIN
   IF (r.kind # 1) AND (r.kind # 5) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   IF (r.kind = 1) AND symtab [r.idx].isPort THEN
      ParseExpr (src) ;
      IF NOT OK () THEN RETURN END ;
      LoadAtom (src) ;
      EmLoadVar (FALSE, symtab [tmpA].off, 2) ;
      EmMovDxAx () ;
      Ebyte (0EEH) ;                       (* OUT DX,AL *)
      RETURN
   END ;
   IF IsCharArray (r) AND ((r.kind = 1) OR (r.kind = 5)) THEN
      (* Fixed CHAR arrays are Pascal strings too, but they have no length
         byte: a literal fills the array and pads the tail with spaces. *)
      ParseExpr (src) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF src.kind = 3 THEN
         n := VarSize (r) ;
         k := 0 ;
         WHILE k < n DO
            IF k < strLen [src.strx] THEN
               IF r.kind = 5 THEN
                  EmStDiImm (k, ORD (strPool [strOff [src.strx] + k]))
               ELSE
                  EmMovAxi (ORD (strPool [strOff [src.strx] + k])) ;
                  StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1)
               END
            ELSE
               IF r.kind = 5 THEN
                  EmStDiImm (k, ORD (' '))
               ELSE
                  EmMovAxi (ORD (' ')) ;
                  StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1)
               END
            END ;
            INC (k)
         END ;
         RETURN
      END ;
      Err (ETypeErr) ;
      RETURN
   END ;
   IF ((r.kind = 1) OR (r.kind = 5)) AND (VarSize (r) > 2)
      AND ((r.cls = TRecord) OR (r.cls = TArray)) THEN
      (* Whole record/array assignment: copy VarSize(r) bytes.  This is what
         BIGREC/DYNREC's `Mother := Self', `Father^ := Mother^' and
         `Friend[Index] := Mother' need.  A DI-addressed destination has to
         be parked before the source expression can reuse DI. *)
      IF r.kind = 5 THEN
         EmPushDi ()
      END ;
      ParseExpr (src) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF (src.kind # 1) AND (src.kind # 5) THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      IF VarSize (src) # VarSize (r) THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      IF src.kind = 5 THEN
         EmPushDi ()
      ELSE
         EmPushSymAddr (src.idx, (symtab [src.idx].off + src.boff) MOD 10000H)
      END ;
      IF r.kind = 5 THEN
         (* stack now holds dest, source; make it source, dest for the ABI *)
         EmPopAx () ;
         EmPopBx () ;
         EmPushAx () ;
         EmPushBx ()
      ELSE
         EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
      END ;
      EmMovCxi (VarSize (r)) ;
      DropC (EmCall (TU_MemCopy)) ;
      EmAddSp (4) ;
      RETURN
   END ;
   IF r.cls = TReal THEN
      (* A 6-byte REAL.  A compile-time ordinal constant is converted to the
         measured MBF layout; another REAL field is copied byte for byte.
         Real arithmetic and real-valued expressions are a later stage and
         are refused, not guessed. *)
      IF (r.kind = 1) AND symtab [r.idx].isVar THEN
         (* VAR REAL parameter: the slot holds the destination address. *)
         ParseExpr (src) ;
         IF NOT OK () THEN
            RETURN
         END ;
         IF (src.kind = 0) AND (src.cls # TString) AND (src.cls # TSet) THEN
            IntToMbf (src.imm, rbuf) ;
            LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
            EmMovDiAx () ;
            k := 0 ;
            WHILE k < 6 DO
               EmStDiImm (k, ORD (rbuf [k])) ;
               INC (k)
            END ;
            RETURN
         END ;
         IF (src.cls = TReal) AND ((src.kind = 1) OR (src.kind = 5)) THEN
            (* Destination pointer first, then the source address; pop SI
               (source), DI (destination), and copy six bytes. *)
            LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
            EmPushAx () ;
            IF src.kind = 5 THEN
               EmPushDi ()
            ELSIF symtab [src.idx].isVar THEN
               LoadSymVar (src.idx, symtab [src.idx].off, 2) ;
               EmPushAx ()
            ELSE
               EmPushSymAddr (src.idx, (symtab [src.idx].off + src.boff) MOD 10000H)
            END ;
            EmPopSi () ;
            EmPopDi () ;
            k := 0 ;
            WHILE k < 6 DO
               EmLdAlSi () ;
               EmStDiAl () ;
               EmIncSi () ;
               EmIncDi () ;
               INC (k)
            END ;
            RETURN
         END ;
         Err (ENoLib) ;
         RETURN
      END ;
      IF r.kind = 5 THEN
         EmPushDi ()
      END ;
      ParseExpr (src) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF (src.cls # TReal) AND (src.cls # TString) AND (src.cls # TSet)
         AND (src.kind # 0) AND ((r.kind = 1) OR (r.kind = 5)) THEN
         (* INTEGER/CHAR/BOOLEAN -> REAL, e.g. Size := Count in CONVERT. *)
         scratch := NewScratchReal () ;
         RealOperand (src, symtab [scratch].off) ;
         IF r.kind = 5 THEN
            EmPopDi ()
         END ;
         k := 0 ;
         WHILE k < 6 DO
            LoadSymVar (scratch, (symtab [scratch].off + k) MOD 10000H, 1) ;
            IF r.kind = 5 THEN
               EmStDiAlOff (k)
            ELSE
               StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1)
            END ;
            INC (k)
         END ;
         RETURN
      END ;
      IF (src.kind = 0) AND (src.cls # TString) AND (src.cls # TSet) THEN
         IntToMbf (src.imm, rbuf) ;
         IF r.kind = 5 THEN
            EmPopDi () ;
            k := 0 ;
            WHILE k < 6 DO
               EmStDiImm (k, ORD (rbuf [k])) ;
               INC (k)
            END
         ELSIF r.kind = 1 THEN
            k := 0 ;
            WHILE k < 6 DO
               EmMovAxi (ORD (rbuf [k])) ;
               StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ;
               INC (k)
            END
         ELSE
            Err (ENoLib)
         END ;
         RETURN
      END ;
      IF (src.kind = 5) AND (src.cls = TReal) AND (r.kind = 5) THEN
         EmPushDi () ;                 (* source address *)
         EmPopSi () ;
         EmPopDi () ;                  (* destination address *)
         k := 0 ;
         WHILE k < 6 DO
            EmLdAlSi () ; EmStDiAl () ; EmIncSi () ; EmIncDi () ;
            INC (k)
         END ;
         RETURN
      END ;
      IF (src.kind = 5) AND (src.cls = TReal) AND (r.kind = 1) THEN
         EmPushDi () ;
         EmPopSi () ;
         k := 0 ;
         WHILE k < 6 DO
            EmLdAlSi () ;
            StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ;
            EmIncSi () ;
            INC (k)
         END ;
         RETURN
      END ;
      IF (src.kind = 1) AND (src.cls = TReal) THEN
         IF r.kind = 5 THEN
            IF src.kind = 5 THEN
               Err (ENoLib) ;
               RETURN
            END ;
            EmPopDi () ;
            k := 0 ;
            WHILE k < 6 DO
               LoadSymVar (src.idx, (symtab [src.idx].off + src.boff + k) MOD 10000H, 1) ;
               EmStDiAlOff (k) ;
               INC (k)
            END
         ELSIF r.kind = 1 THEN
            k := 0 ;
            WHILE k < 6 DO
               LoadSymVar (src.idx, (symtab [src.idx].off + src.boff + k) MOD 10000H, 1) ;
               StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ;
               INC (k)
            END
         ELSE
            Err (ENoLib)
         END ;
         RETURN
      END ;
      Err (ENoLib) ;
      RETURN
   END ;
   IF r.cls = TSet THEN
      (* `field := [elements]'.  The constructor's TYPE comes from the target:
         CALC's CellStatus is `set of Attributes' (one byte), not the default
         32-byte `set of Char' an untyped literal would become.  The bytes are
         known at compile time; store them at symbol+boff or through DI. *)
      IF (r.setsize = 0) OR (r.setsize > 32) THEN
         Err (ENoLib) ;
         RETURN
      END ;
      Skip () ;
      IF CurCh () = '[' THEN
         (* A leading constructor normally belongs to the TARGET, because its
            type (e.g. CALC's one-byte `set of Attributes') is narrower than
            the default 32-byte literal.  But `[A..D] - X' is an expression:
            parse it through ParseExpr instead of storing it directly.  The
            source cursor is reversible, so try the constructor first. *)
         savePos := srcPos ;
         IF NOT RdSetLiteral (r.setbase, r.setsize, sbuf) THEN
            RETURN
         END ;
         Skip () ;
         IF (CurCh () = '+') OR (CurCh () = '-') OR (CurCh () = '*') THEN
            srcPos := savePos
         ELSE
            IF r.kind = 5 THEN
               k := 0 ;
               WHILE k < r.setsize DO
                  EmStDiImm (k, ORD (sbuf [k])) ;
                  INC (k)
               END
            ELSIF r.kind = 1 THEN
               k := 0 ;
               WHILE k < r.setsize DO
                  EmMovAxi (ORD (sbuf [k])) ;
                  StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ;
                  INC (k)
               END
            ELSE
               Err (ENoLib)
            END ;
            RETURN
         END
      END ;
      (* `set := set' or a set expression.  The destination is a variable
         or a DI-addressed field; save the DI address BEFORE the right-hand
         expression can reuse DI, then copy the runtime's bytes. *)
      IF r.kind = 5 THEN
         EmPushDi ()
      END ;
      ParseExpr (src) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF src.cls # TSet THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      IF src.kind = 9 THEN
         MaterializeDyn (src, r.setbase, r.setsize)
      END ;
      IF r.kind = 1 THEN
         EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
      ELSIF r.kind # 5 THEN
         Err (ENoLib) ;
         RETURN
      END ;
      EmPushSetAddr (src) ;
      n := r.setsize ;
      IF (src.kind = 8) AND (src.setsize < n) THEN
         n := src.setsize
      END ;
      EmMovAxi (n) ;
      EmPushAx () ;
      DropC (EmCall (TU_SetCopy)) ;
      EmAddSp (4) ;
      RETURN
   END ;
   IF (r.kind = 5) AND (r.cls = TString) THEN
      (* A string field of a DI-addressed record element.  DI is the field's
         address; park it because the source expression may reuse DI. *)
      EmPushDi () ;
      ParseExpr (src) ;
      IF NOT OK () THEN
         RETURN
      END ;
      n := VarSize (r) - 1 ;              (* usable characters *)
      IF src.kind = 3 THEN
         EmPopDi () ;
         IF strLen [src.strx] < n THEN
            n := strLen [src.strx]
         END ;
         EmStDiImm (0, n) ;               (* the length byte *)
         k := 1 ;
         WHILE k <= n DO
            EmStDiImm (k, ORD (strPool [strOff [src.strx] + k - 1])) ;
            INC (k)
         END
      ELSIF src.kind = 1 THEN
         EmPushSymAddr (src.idx, (symtab [src.idx].off + src.boff) MOD 10000H) ;
         EmPopDi () ;                    (* destination = the field *)
         EmPushDi () ;
         EmMovCxi (n) ;                   (* strstore's limit *)
         DropC (EmCall (TU_StrStore)) ;
         EmAddSp (4)
      ELSIF src.kind = 5 THEN
         EmPushDi () ;                    (* source field address *)
         EmPopSi () ;
         EmPopDi () ;                    (* destination field address *)
         EmPushSi () ;                     (* source address *)
         EmPushDi () ;
         EmMovCxi (n) ;
         DropC (EmCall (TU_StrStore)) ;
         EmAddSp (4)
      ELSE
         Err (ENoLib)
      END ;
      RETURN
   END ;
   IF (r.kind = 1) AND (r.cls = TString) AND symtab [r.idx].isVar THEN
      (* A VAR string parameter: the slot holds the caller's string address.
         Copy through the runtime, exactly as a normal string variable does:
         source address first, destination address second, limit in CX.  This
         covers literals and whole-string expressions alike; the destination
         address is loaded from the parameter slot rather than formed with
         LEA, which would point at the slot itself. *)
      ParseExpr (src) ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF src.cls # TString THEN
         Err (ETypeErr) ;
         RETURN
      END ;
      EmPushStrAddr (src) ;
      LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
      EmPushAx () ;
      EmMovCxi ((VarSize (r) - 1) MOD 10000H) ;
      DropC (EmCall (TU_StrStore)) ;
      EmAddSp (4) ;
      RETURN
   END ;
   IF (r.kind = 1) AND symtab [r.idx].isVar THEN
      (* `varparam := expr': store through the address the slot holds.  DI is
         parked across the right-hand side because that expression may use DI
         for a string element of its own. *)
      IF r.boff # 0 THEN
         Err (ENoLib) ;
         RETURN
      END ;
      StoreVarIndPrepSym (r.idx) ;
      ParseExpr (src) ;
      LoadAtom (src) ;
      EmPopDi () ;
      EmStoreInd (VarSize (r)) ;
      RETURN
   END ;
   IF (r.cls = TString) AND (VarSize (r) > 1) THEN
      (* s := <string literal>.  TPSRC8 asn2 sends a string through the scalar
         store path, and estcpl's string arm emits `MOV CL,max_len' (max_len =
         varsize-1) then `CALL strstore', which copies the source - length byte
         and characters - into the destination and TRUNCATES a source longer
         than max_len by rewriting the length byte (TPSRC2 strstore's
         `CMP.B CL,AL / JBE stslenok / MOV.B [SI],AL').  Here the literal is
         known at compile time, so its bytes become immediate stores instead of
         a stack push and a block move.  The variable that results is the same,
         truncation included, and the tail past the new length is left as it
         was, exactly as strstore leaves it. *)
      ParseExpr (src) ;
      IF (src.cls = TChar) OR ((src.cls = TScalar) AND src.chr) THEN
         (* `s := ch': a one-character string.  This is CALC's
            `EXY := FactorCh' before Val. *)
         IF src.kind = 0 THEN
            EmMovAxi (1) ;
            StoreSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, 1) ;
            EmMovAxi (W16 (src.imm)) ;
            StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + 1) MOD 10000H, 1)
         ELSE
            LoadAtom (src) ;
            StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + 1) MOD 10000H, 1) ;
            EmMovAxi (1) ;
            StoreSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, 1)
         END ;
         RETURN
      END ;
      IF (src.cls # TString) THEN
         Err (ENoLib) ;
         RETURN
      END ;
      IF src.kind # 3 THEN
         (* s := <string variable>.  TPSRC8 asnvar pushes the destination
            address, then the expression (strload) pushes the source, and
            estcpl emits MOV CL,max_len then CALL strstore, which copies
            length byte + chars, TRUNCATING to max_len and leaving the
            destination tail past the new length untouched.  Here both
            addresses are pushed - source first, so it sits at [BP+6] and the
            destination at [BP+4] - the caller pops both, and the limit is a
            full MOV CX,imm16 because this runtime reads it in CX outright. *)
         IF src.kind = 1 THEN
            EmPushSymAddr (src.idx, (symtab [src.idx].off + src.boff) MOD 10000H)
         ELSIF src.kind = 5 THEN
            (* A string element reached through DI, including a pointer
               dereference: Buffer^[i].  Its address is already in DI. *)
            EmPushDi ()
         ELSE
            Err (ENoLib) ;          (* a computed string is not a value *)
            RETURN
         END ;
         EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
         EmMovCxi ((VarSize (r) - 1) MOD 10000H) ;
         DropC (EmCall (TU_StrStore)) ;
         EmAddSp (4) ;
         RETURN
      END ;
      n := strLen [src.strx] ;
      IF n > VarSize (r) - 1 THEN
         n := VarSize (r) - 1
      END ;
      EmMovAxi (n) ;
      StoreSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, 1) ;
      k := 0 ;
      WHILE k < n DO
         EmMovAxi (ORD (strPool [strOff [src.strx] + k])) ;
         StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + 1 + k) MOD 10000H, 1) ;
         INC (k)
      END ;
      RETURN
   END ;
   IF (r.kind = 5) OR (VarSize (r) > 2) THEN
      IF r.kind = 5 THEN
         (* An element addressed by DI: a string character (one byte) or an
            array element (one or two).  A wider element - a record - is
            refused rather than stored as its first two bytes.

            The destination address is in DI, and the right-hand side is
            parsed next, so DI has to be saved first - the RHS may hold a
            subscript of its own, which reuses DI, or call a routine that
            clobbers it.  This is TPSRC8 asnscal2/asnscal3 (758-760, 786-789),
            which set flgpshdi around the expression for the same reason. *)
         IF VarSize (r) > 2 THEN
            Err (ENoLib) ;
            RETURN
         END ;
         EmPushDi () ;
         ParseExpr (src) ;
         LoadAtom (src) ;
         IF BoundsOf (r, blo, bhi) THEN
            EmitBoundsCheck (blo, bhi, 17)
         END ;
         EmPopDi () ;                    (* DI := the destination again *)
         EmStoreInd (VarSize (r)) ;      (* [DI] := AL or AX *)
         RETURN
      END ;
      (* A value wider than a word with no address to store through: an
         assignment to a whole string/record/array is not a scalar store. *)
      Err (ENoLib) ;
      RETURN
   END ;
   ParseExpr (src) ;
   LoadAtom (src) ;
   IF BoundsOf (r, blo, bhi) THEN
      EmitBoundsCheck (blo, bhi, 17)
   END ;
   StoreSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, VarSize (r))
END Assignment ;

PROCEDURE Compound () ;
(* BEGIN statement ';' ... END; END is consumed here *)
VAR tok : CARDINAL ;
BEGIN
   LOOP
      PeekKw (tok) ;
      IF tok = TkEnd THEN
         DropB (MatchKey (tok)) ;
         RETURN
      END ;
      Statmnt () ;
      IF NOT OK () THEN
         RETURN
      END ;
      IF NOT MatchDelim (';') THEN
         PeekKw (tok) ;
         IF tok = TkEnd THEN
            DropB (MatchKey (tok)) ;
            RETURN
         END ;
         Err (ENoSemi) ;
         RETURN
      END
   END
END Compound ;

PROCEDURE EmCrtSeq (which : CARDINAL) ;
(* The CRT byte sequences, in one parameterised helper.  Every one is a fixed
   BIOS call:
     CrtClr   - INT 10h AH=06 blank the whole window, then AH=02 home the cursor
     CrtDl    - DEC AX ; MOV DL,AL   (a 1-based column -> 0-based)
     CrtDh    - DEC AX ; MOV DH,AL   (a 1-based row)
     CrtCaret - INT 10h AH=02, page 0, cursor at DH,DL
   It takes a parameter on purpose: audit_helpers audits helpers with an EMPTY
   parameter list byte-for-byte, and these multi-instruction sequences have no
   single name grammar.  Listed as COMP in NON_ONE_LINE, like SetBlob. *)
BEGIN
   IF which = CrtClr THEN
      Ebyte (0B8H) ; Ebyte (00H) ; Ebyte (06H) ;   (* MOV AX,0600h *)
      Ebyte (8AH) ; Ebyte (3EH) ; Eword ((crtAttrOff + LoadBias) MOD 10000H) ; (* MOV BH,[crtAttr] *)
      Ebyte (0B9H) ; Ebyte (00H) ; Ebyte (00H) ;   (* MOV CX,0000h *)
      Ebyte (0BAH) ; Ebyte (4FH) ; Ebyte (18H) ;   (* MOV DX,184Fh *)
      Ebyte (0CDH) ; Ebyte (10H) ;                 (* INT 10h      *)
      Ebyte (0B8H) ; Ebyte (00H) ; Ebyte (02H) ;   (* MOV AX,0200h *)
      Ebyte (0B7H) ; Ebyte (00H) ;                 (* MOV BH,00h   *)
      Ebyte (0BAH) ; Ebyte (00H) ; Ebyte (00H) ;   (* MOV DX,0000h *)
      Ebyte (0CDH) ; Ebyte (10H)                  (* INT 10h      *)
   ELSIF which = CrtDl THEN
      Ebyte (48H) ;                                (* DEC AX    *)
      Ebyte (88H) ; Ebyte (0C2H)                   (* MOV DL,AL *)
   ELSIF which = CrtDh THEN
      Ebyte (48H) ;                                (* DEC AX    *)
      Ebyte (88H) ; Ebyte (0C6H)                   (* MOV DH,AL *)
   ELSIF which = CrtEol THEN
      Ebyte (0B4H) ; Ebyte (03H) ;                 (* MOV AH,03h  get cursor *)
      Ebyte (0B7H) ; Ebyte (00H) ;                 (* MOV BH,00h             *)
      Ebyte (0CDH) ; Ebyte (10H) ;                 (* INT 10h  -> DH,DL      *)
      Ebyte (89H) ; Ebyte (0D1H) ;                 (* MOV CX,DX  upper-left   *)
      Ebyte (0B2H) ; Ebyte (4FH) ;                 (* MOV DL,4Fh  col 79      *)
      Ebyte (0B8H) ; Ebyte (00H) ; Ebyte (06H) ;   (* MOV AX,0600h blank      *)
      Ebyte (8AH) ; Ebyte (3EH) ; Eword ((crtAttrOff + LoadBias) MOD 10000H) ; (* MOV BH,[crtAttr] *)
      Ebyte (0CDH) ; Ebyte (10H)                  (* INT 10h                 *)
   ELSIF which = CrtLow THEN
      (* [crtAttr] := 7: the dim attribute ClrScr/ClrEol use from now on.  The
         runtime's console writer is INT 21h teletype, which has no attribute
         channel, but the clear operations do - so this is where the setting is
         observable, not a no-op. *)
      Ebyte (0C6H) ; Ebyte (06H) ; Eword ((crtAttrOff + LoadBias) MOD 10000H) ; Ebyte (07H)
   ELSIF which = CrtNorm THEN
      Ebyte (0C6H) ; Ebyte (06H) ; Eword ((crtAttrOff + LoadBias) MOD 10000H) ; Ebyte (0FH)
   ELSIF which = CrtKey THEN
      (* KeyPressed: DOS AH=0Bh asks whether a character is waiting.  AL is
         0FFh when one is, 0 when not; the boolean representation here is 0/1.
         AND AX,1, not AND AL,1: the interrupt leaves AH = 0Bh, so the
         comparison that follows (`CMP AX,0') would read 0B00h and call the
         false case TRUE.  bootcom happened to return AH=0 (it IRETs the
         handler's whole AX) and hid this; hlt.  No argument, no runtime
         entry. *)
      Ebyte (0B4H) ; Ebyte (0BH) ;                 (* MOV AH,0Bh           *)
      Ebyte (0CDH) ; Ebyte (21H) ;                 (* INT 21h              *)
      Ebyte (25H) ; Ebyte (01H) ; Ebyte (00H)      (* AND AX,1             *)
   ELSIF which = CrtDelay THEN
      (* Delay(AX) milliseconds: TP3's xdelay, a calibrated busy loop.  The
         count 110 is TP3's default `delaycnt' for 1 ms (TPSRC1).  AX = 0 does
         nothing. *)
      (* OR AX,AX, not CMP AX,0: check_8086 treats every `CMP AX,0000' in the
         program region as one of the IF/WHILE/REPEAT tests and demands
         Jcc+3;EJMP after it.  This is neither. *)
      Ebyte (0BH) ; Ebyte (0C0H) ;                (* OR AX,AX            *)
      Ebyte (74H) ; Ebyte (08H) ;                 (* JZ past the loop    *)
      Ebyte (0B9H) ; Ebyte (6EH) ; Ebyte (00H) ;  (* MOV CX,110 (1 ms)   *)
      Ebyte (0E2H) ; Ebyte (0FEH) ;               (* LOOP -> itself      *)
      Ebyte (48H) ;                               (* DEC AX              *)
      Ebyte (75H) ; Ebyte (0F8H)                  (* JNZ -> MOV CX       *)
   ELSE
      Ebyte (0B4H) ; Ebyte (02H) ;                 (* MOV AH,02h *)
      Ebyte (0B7H) ; Ebyte (00H) ;                 (* MOV BH,00h *)
      Ebyte (0CDH) ; Ebyte (10H)                  (* INT 10h    *)
   END
END EmCrtSeq ;

PROCEDURE LabelColonAhead () : BOOLEAN ;
(* `Label:' is a statement label, but `Name;' is a procedure call.  Look
   past an identifier and blanks without consuming input. *)
VAR k : CARDINAL ;
    ch : CHAR ;
BEGIN
   k := 0 ;
   ch := PeekAhead (k) ;
   IF NOT Alpha (ch) THEN
      RETURN FALSE
   END ;
   WHILE AlphaNum (ch) DO
      INC (k) ;
      ch := PeekAhead (k)
   END ;
   WHILE ch = ' ' DO
      INC (k) ;
      ch := PeekAhead (k)
   END ;
   IF ch # ':' THEN
      RETURN FALSE
   END ;
   (* `Name := ...' is an assignment, not a label definition. *)
   INC (k) ;
   ch := PeekAhead (k) ;
   WHILE ch = ' ' DO
      INC (k) ;
      ch := PeekAhead (k)
   END ;
   RETURN ch # '='
END LabelColonAhead ;

PROCEDURE Statmnt () ;
VAR tok : CARDINAL ;
    idx, i2 : CARDINAL ;
    t, src : ERes ;
    L1, zj, zj2, exj : CARDINAL ;
    lo, hi, v : LONGINT ;
    clso : CARDINAL ;
    i : CARDINAL ;
    k, nlbl, nlblJmp, bodyPc, skipJmp : CARDINAL ;
    nm : ARRAY [0..MaxName] OF CHAR ;
    strf : BOOLEAN ;
    dow : BOOLEAN ;
    savedWith : CARDINAL ;
BEGIN
   Skip () ;
   IF Digit (CurCh ()) OR LabelColonAhead () THEN
      ParseLabelStmt () ;      (* consumed the label and ':' *)
      Statmnt () ;             (* the statement follows the label directly *)
      RETURN
   END ;
   IF NOT Alpha (CurCh ()) THEN
      ExpectDelim (';', ENoSemi) ;
      RETURN
   END ;
   DropB (MatchKey (tok)) ;
   IF tok = TkBegin THEN
      Compound ()
   ELSIF tok = TkIf THEN
      ParseExpr (t) ;
      LoadAtom (t) ;
      EmCmpAxi (0) ;
      zj := EmJcc (84H, 0) ;          (* JZ -> else/end *)
      IF NOT (MatchKey (tok) AND (tok = TkThen)) THEN
         Err (ENoSemi)
      END ;
      Statmnt () ;
      (* Peek the ELSE, do not match it.  `MatchKey (tok) AND (tok = TkElse)`
         consumes whatever the next keyword is even when the AND fails, so an
         `if` that was the LAST statement of a BEGIN..END block ate the block's
         own END: Compound then found neither ';' nor END and raised ENoSemi.
         Any `if` as the last statement of a compound was unparseable - not
         in a loop, not anywhere - and no fixture had one, so nothing noticed.
         The visible symptom was a parse error at the statement AFTER the
         block, which points at entirely the wrong piece of source. *)
      PeekKw (tok) ;
      IF tok = TkElse THEN
         DropB (MatchKey (tok)) ;
         exj := EmJmpNear (0) ;
         SetPatTgt (zj, pc) ;
         Statmnt () ;
         SetPatTgt (exj, pc)
      ELSE
         SetPatTgt (zj, pc)
      END
   ELSIF tok = TkWhile THEN
      L1 := pc ;
      ParseExpr (t) ;
      LoadAtom (t) ;
      EmCmpAxi (0) ;
      zj := EmJcc (84H, 0) ;          (* JZ -> end *)
      IF NOT (MatchKey (tok) AND (tok = TkDo)) THEN
         Err (ENoSemi)
      END ;
      brkSave [brkN] := exitCnt ;
      loopTy [brkN] := 1 ;
      INC (brkN) ;
      Statmnt () ;
      DEC (brkN) ;
      i := brkSave [brkN] ;
      WHILE i < exitCnt DO
         SetPatTgt (exitPatch [i], pc) ;
         INC (i)
      END ;
      exitCnt := brkSave [brkN] ;
      DropC (EmJmpNear (L1)) ;
      SetPatTgt (zj, pc)
   ELSIF tok = TkRepeat THEN
      L1 := pc ;
      brkSave [brkN] := exitCnt ;
      loopTy [brkN] := 1 ;
      INC (brkN) ;
      (* The body is a STATEMENT SEQUENCE, not one statement: `repeat a; b
         until c'.  This used to call Statmnt once and then demand UNTIL, so
         any body with a second statement was ENoSemi at the first ';'.  t12's
         two bodies are single statements and never saw it; CALC's `Flash' does
         (GotoXY; Blink := not Blink; if ...; Write; Delay).  Same shape as
         Compound, stopping at UNTIL instead of END. *)
      LOOP
         PeekKw (tok) ;
         IF tok = TkUntil THEN
            DropB (MatchKey (tok)) ;
            EXIT
         END ;
         Statmnt () ;
         IF NOT OK () THEN
            RETURN
         END ;
         IF NOT MatchDelim (';') THEN
            PeekKw (tok) ;
            IF tok = TkUntil THEN
               DropB (MatchKey (tok)) ;
               EXIT
            END ;
            Err (ENoSemi) ;
            RETURN
         END
      END ;
      ParseExpr (t) ;
      LoadAtom (t) ;
      EmCmpAxi (0) ;
      (* UNTIL exits when the condition is TRUE, so the body runs again when
         it is FALSE.  The condition is a 0/1 in AX and EmCmpAxi (0) has just
         compared it with 0, so ZF=1 means "condition false" -- which is
         exactly the case that loops, hence JZ.
         This was JNZ, which compiled repeat-until as while-until: the body
         ran once, the condition was tested, and it stopped.  t12_repeat is
         `i:=0; repeat i:=i+1 until i>5' and it printed 1.
         No patch slot: L1 is backwards and already known, so EmJcc returns
         0 and there is nothing to SetPatTgt. *)
      DropC (EmJcc (84H, L1)) ;        (* JZ -> body again *)
      DEC (brkN) ;
      i := brkSave [brkN] ;
      WHILE i < exitCnt DO
         SetPatTgt (exitPatch [i], pc) ;
         INC (i)
      END ;
      exitCnt := brkSave [brkN]
   ELSIF tok = TkFor THEN
      (* control variable *)
      Skip () ;                   (* after the FOR keyword: skip blanks *)
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      GetWord () ;
      IF NOT Search (wrd, idx) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      IF symtab [idx].size > 2 THEN
         Err (ENoLib) ;
         RETURN
      END ;
      IF NOT MatchAssign () THEN
         Err (ENoSemi)
      END ;
      ParseExpr (src) ;
      LoadAtom (src) ;
      StoreSymVar (idx, symtab [idx].off, symtab [idx].size) ;
      IF NOT MatchKey (tok) THEN
         Err (ESimpType) ;
         RETURN
      END ;
      IF (tok = TkTo) OR (tok = TkDownto) THEN
         dow := (tok = TkDownto)
      ELSE
         Err (ESimpType) ;
         RETURN
      END ;
      ParseExpr (t) ;
      LoadAtom (t) ;
      EmPushAx () ;                    (* loop bound on the stack *)
      IF NOT (MatchKey (tok) AND (tok = TkDo)) THEN
         Err (ENoSemi)
      END ;
      brkSave [brkN] := exitCnt ;
      loopTy [brkN] := 2 ;
      INC (brkN) ;
      L1 := pc ;                       (* Ltest: the test comes FIRST *)
      (* The test is emitted before the body, not after it.  It used to be
         emitted after, which is a post-test loop and runs the body one time
         too many: with `for i := 1 to 5`, the sequence of i at the test is
         1,2,3,4,5,6 - the test at i=5 is `5 > 5`, which is false, so the
         body ran a sixth time with i=6.  `for i := 1 to 5 do s := s + i`
         printed 21.  The size was right and the shape was right; only the
         order was wrong, and no byte check can see an order.

         The bound stays on the stack for the whole loop, so EmMovCxSp has to
         re-read it every iteration - which is also what makes the bound a
         *variable* rather than a constant.  [SP] cannot be encoded on the
         8086, so EmMovCxSp is POP CX ; PUSH CX, an observational no-op that
         leaves the bound in place. *)
      EmMovCxSp () ;
      LoadSymVar (idx, symtab [idx].off, symtab [idx].size) ;
      IF symtab [idx].size = 1 THEN
         (* A CHAR/BYTE control variable loads into AL only.  Without zeroing
            AH, the previous body's leftover AH (wrchar leaves 02h there) makes
            the 16-bit CMP read 0242h and the loop stops after 'A'. *)
         EmMovAh0 ()
      END ;
      EmCmpAxCx () ;
      IF dow THEN
         zj := EmJcc (8CH, 0)          (* JL -> done *)
      ELSE
         zj := EmJcc (8FH, 0)          (* JG -> done *)
      END ;
      Statmnt () ;
      DEC (brkN) ;
      (* A FOR's exits are NOT patched here, even though `done` is not known
         yet.  For a WHILE or REPEAT, "just after the body" is a correct
         target: the jump back to the test re-evaluates the condition and
         leaves.  For a FOR there is a STEP between the body and `done`, so
         an EXIT that jumped here would increment the control variable and
         jump back to the test - and if the incremented value still satisfied
         the bound, it would run the body AGAIN.  `exit` did not exit.

         The fix needs no new bookkeeping: `brkSave [brkN] .. exitCnt` still
         names exactly this loop's exits, because Statmnt may have added more
         and nothing has reset exitCnt.  So they are patched at `done`, below.
         A WHILE nested inside the FOR saves and restores its own range and
         leaves this one intact. *)
      (* step *)
      LoadSymVar (idx, symtab [idx].off, symtab [idx].size) ;
      IF symtab [idx].size = 1 THEN
         EmMovAh0 ()
      END ;
      IF dow THEN
         EmDecAx ()
      ELSE
         EmIncAx ()
      END ;
      StoreSymVar (idx, symtab [idx].off, symtab [idx].size) ;
      DropC (EmJmpNear (L1)) ;
      SetPatTgt (zj, pc) ;             (* done: *)
      (* A WHILE loop here, not a FOR over the exit range.  The range is
         usually EMPTY - most loops have no `exit` - and `exitCnt` is a
         CARDINAL, so `TO exitCnt - 1` with exitCnt = 0 is `TO 65535`: the
         loop does not terminate, it wraps, and it walks exitPatch [0..65535]
         off the end of a 64-element array.  `for i := 1 to 10 do i := i` has
         no exit, so this is the ORDINARY case, and it faulted with
         "invalid address referenced" on every FOR loop without an exit. *)
      i := brkSave [brkN] ;
      WHILE i < exitCnt DO
         SetPatTgt (exitPatch [i], pc) ;
         INC (i)
      END ;
      exitCnt := brkSave [brkN] ;
      EmAddSp (2)                      (* drop the loop bound *)
   ELSIF tok = TkCase THEN
      ParseExpr (t) ;
      LoadAtom (t) ;
      EmPushAx () ;                    (* selector on the stack *)
      IF NOT (MatchKey (tok) AND (tok = TkOf)) THEN
         Err (ENoSemi)
      END ;
      caseN := 0 ;
      LOOP
         Skip () ;
         IF MatchDelim (';') THEN
            Skip ()
         END ;
         PeekKw (tok) ;
         IF (tok = TkEnd) OR (tok = TkElse) THEN
            EXIT
         END ;
         (* Case labels: `v' | `lo..hi', comma-separated, all selecting the
            same statement (CALC's `'G', 'I', 'O', 'Q':').  Read the whole list
            first; the emission then knows whether this is the one-label path
            or a list. *)
         nlbl := 0 ;
         LOOP
            IF Alpha (CurCh ()) THEN
               GetWord () ;
               IF Search (wrd, i2) AND (symtab [i2].tag = KConst) THEN
                  lo := symtab [i2].lval
               ELSE
                  Err (EUnknown) ;
                  RETURN
               END
            ELSE
               RdConst (lo, clso, strf)
            END ;
            IF MatchRange () THEN
               RdConst (hi, clso, strf)
            ELSE
               hi := lo
            END ;
            IF nlbl >= 32 THEN
               Err (ECompOvf) ;
               RETURN
            END ;
            lblLo [nlbl] := lo ;
            lblHi [nlbl] := hi ;
            INC (nlbl) ;
            IF MatchDelim (',') THEN
               Skip ()
            ELSE
               EXIT
            END
         END ;
         Skip () ;
         ExpectDelim (':', ENoSemi) ;
         IF NOT OK () THEN
            RETURN
         END ;
         EmMovAxSp () ;
         IF nlbl = 1 THEN
            (* One label: the original bytes, except that a RANGE is now a
               real range.  It used to compare AX with lo and then with hi,
               both demanding equality, so `1..5' matched NOTHING unless
               lo = hi - a silently wrong answer, not an error. *)
            lo := lblLo [0] ;
            hi := lblHi [0] ;
            IF hi = lo THEN
               EmCmpAxi (W16 (lo)) ;
               zj := EmJcc (85H, 0) ;        (* JNZ -> next arm *)
               zj2 := 0
            ELSE
               EmCmpAxi (W16 (lo)) ;
               zj := EmJcc (8CH, 0) ;        (* JL -> next arm *)
               EmCmpAxi (W16 (hi)) ;
               zj2 := EmJcc (8FH, 0)         (* JG -> next arm *)
            END ;
            Statmnt () ;
            IF caseN >= 64 THEN
               Err (ECompOvf) ;
               RETURN
            END ;
            caseJmp [caseN] := EmJmpNear (0) ;
            INC (caseN) ;
            SetPatTgt (zj, pc) ;
            IF zj2 # 0 THEN
               SetPatTgt (zj2, pc)
            END
         ELSE
            (* A list.  A single label branches INTO the statement; a range
               first sends AX below lo to the next label, then `<= hi' to the
               body.  The body jumps are patched once the body's address is
               known, and the no-match EJMP skips the body to the next arm. *)
            nlblJmp := 0 ;
            FOR k := 0 TO nlbl - 1 DO
               IF lblHi [k] = lblLo [k] THEN
                  EmCmpAxi (W16 (lblLo [k])) ;
                  lblJmp [nlblJmp] := EmJcc (84H, 0) ;  (* JZ -> body *)
                  INC (nlblJmp)
               ELSE
                  (* `lo <= AX <= hi', built from the two conditions this
                     compiler declares for a branch (L and G): below lo skips
                     the label, above hi skips it, otherwise an unconditional
                     jump enters the body.  JLE would be shorter and is legal
                     8086, but check_8086's declared condition set is exactly
                     Z/NZ/L/G (the four the parser's comparisons use), and a
                     new condition in CASE would rightly be reported there. *)
                  EmCmpAxi (W16 (lblLo [k])) ;
                  zj := EmJcc (8CH, 0) ;               (* JL -> next label *)
                  EmCmpAxi (W16 (lblHi [k])) ;
                  zj2 := EmJcc (8FH, 0) ;              (* JG -> next label *)
                  lblJmp [nlblJmp] := EmJmpNear (0) ;  (* in range -> body *)
                  INC (nlblJmp) ;
                  SetPatTgt (zj, pc) ;
                  SetPatTgt (zj2, pc)
               END
            END ;
            skipJmp := EmJmpNear (0) ;
            bodyPc := pc ;
            FOR k := 0 TO nlblJmp - 1 DO
               SetPatTgt (lblJmp [k], bodyPc)
            END ;
            Statmnt () ;
            IF caseN >= 64 THEN
               Err (ECompOvf) ;
               RETURN
            END ;
            caseJmp [caseN] := EmJmpNear (0) ;
            INC (caseN) ;
            SetPatTgt (skipJmp, pc)
         END
      END ;
      IF tok = TkElse THEN
         DropB (MatchKey (tok)) ;
         Statmnt () ;
         (* A semicolon between the ELSE statement and the CASE's END is an
            empty statement, and TP3/CALC writes it after a compound body:
            `else begin ... end; end`.  The non-ELSE path already tolerates
            the same separator at the top of the arm loop. *)
         IF MatchDelim (';') THEN
            Skip ()
         END ;
         IF NOT (MatchKey (tok) AND (tok = TkEnd)) THEN
            Err (ENoSemi)
         END
      ELSE
         DropB (MatchKey (tok))
      END ;
      EmAddSp (2) ;
      FOR i := 0 TO caseN - 1 DO
         SetPatTgt (caseJmp [i], pc)
      END
   ELSIF tok = TkGoto THEN
      v := 0 ;
      Skip () ;                  (* after the GOTO keyword: skip blanks *)
      IF Alpha (CurCh ()) THEN
         GetWord () ;
         SaveWord (nm)
      ELSIF Digit (CurCh ()) THEN
         RdIntConst (v) ;
         NumToName (W16 (v), nm)
      ELSE
         Err (EUnknown) ;
         RETURN
      END ;
      IF Search (nm, idx) THEN
            IF symtab [idx].tag = KLabel THEN
               IF symtab [idx].defnd THEN
                  DropC (EmJmpNear (symtab [idx].goPos))
               ELSE
                  zj := EmJmpNear (0) ;
                  AddPend (0, idx, zj)
               END
            ELSE
               Err (EUnknown)
            END
      ELSE
         idx := NewSym (nm, KLabel, TScalar, 0, 0, 0, 0, FALSE) ;
         zj := EmJmpNear (0) ;
         AddPend (0, idx, zj)
      END
   ELSIF tok = TkExit THEN
      IF brkN = 0 THEN
         Err (EUnknown)
      ELSE
         (* No EmAddSp (2) here, even inside a FOR.  The FOR's `done` label
            drops the bound, so an EXIT that jumped to `done` would drop it a
            second time - 4 bytes off a stack that only had 2 to give, which
            silently corrupts the caller's frame.  It used to do exactly
            that, and it was doubly wrong: the exits were patched to the STEP
            rather than to `done`, so the EXIT also incremented the control
            variable and jumped back into the test. *)
         zj := EmJmpNear (0) ;
         IF exitCnt < 64 THEN
            exitPatch [exitCnt] := zj ;
            INC (exitCnt)
         END
      END
   ELSIF tok = TkWith THEN
      (* WITH base (, base)* DO statement.  The record's field range comes from
         the base symbol: DefVar copies the ELEMENT record's recFldFirst/
         recFldLast onto an array variable, which is what makes
         `Sheet[I,J].Field' and `with Sheet[I,J] do' work.  Each base is
         pushed on the scope stack and popped after the statement. *)
      savedWith := withN ;
      LOOP
         ParseExpr (t) ;
         IF NOT OK () THEN
            RETURN
         END ;
         IF t.cls # TRecord THEN
            Err (ETypeErr) ;
            RETURN
         END ;
         IF withN >= 4 THEN
            Err (ECompOvf) ;
            RETURN
         END ;
         IF t.fldFirst >= t.fldLast THEN
            Err (ETypeErr) ;
            RETURN
         END ;
         IF t.kind = 5 THEN
            (* the base address is in DI; park it.  Allocating two data bytes
               here is safe: the statement is parsed once, and the store
               executes wherever the WITH does. *)
            withSlot [withN] := dc ;
            dc := dc + 2 ;
            EmStDiGlob (withSlot [withN]) ;
            withIsDI [withN] := TRUE ;
            withBoff [withN] := 0
         ELSIF t.kind = 1 THEN
            withIsDI [withN] := FALSE ;
            withBoff [withN] := t.boff
         ELSE
            Err (ENoLib) ;
            RETURN
         END ;
         withIdx [withN] := t.idx ;
         withFF [withN] := t.fldFirst ;
         withFL [withN] := t.fldLast ;
         INC (withN) ;
         IF MatchDelim (',') THEN
            (* another base; the last one is innermost *)
         ELSE
            EXIT
         END
      END ;
      IF NOT (MatchKey (tok) AND (tok = TkDo)) THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      Statmnt () ;
      withN := savedWith
   ELSE
      (* identifier statement: assignment or call *)
      IF WithLookup (wrd, t) THEN
         (* A field inside WITH may be followed by `.subfield' or `[index]'. *)
         ParseSub (t) ;
         IF MatchAssign () THEN
            Assignment (t) ;
            RETURN
         END ;
         Err (ENoSemi) ;
         RETURN
      END ;
      IF NOT Search (wrd, idx) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      IF symtab [idx].isPort THEN
         (* Assignment targets take this direct path instead of ParseVar, so
            Port[...] must be routed through the same special parser here. *)
         ParseVar (t) ;
         IF NOT OK () THEN RETURN END ;
         IF MatchAssign () THEN
            Assignment (t)
         ELSE
            Err (ENoSemi)
         END ;
         RETURN
      END ;
      IF symtab [idx].tag = KBuiltin THEN
         IoCall (idx) ;
         RETURN
      END ;
      IF symtab [idx].tag = KProc THEN
         IF MatchDelim ('(') THEN
            ParseCallArgs (idx)
         ELSE
            ParseCall (idx)
         END ;
         RETURN
      END ;
      IF (symtab [idx].tag = KVar) OR (symtab [idx].tag = KFunc) THEN
         t.idx := idx ;
         t.kind := 1 ;
         t.boff := 0 ;
         t.cls := symtab [idx].cls ;
         IF symtab [idx].tag = KFunc THEN
            t.idx := symtab [idx].resvar ;
            t.cls := symtab [t.idx].cls
         END ;
         t.sz := symtab [t.idx].size ;      (* ParseSub may narrow it further *)
         t.fldFirst := symtab [t.idx].fldFirst ;
         t.fldLast := symtab [t.idx].fldLast ;
         t.arrIdx := symtab [t.idx].arrIdx ;
         t.ptrElem := symtab [t.idx].elem ;
         t.hasBounds := ((symtab [t.idx].cls = TScalar) OR (symtab [t.idx].cls = TEnum)
                        OR (symtab [t.idx].cls = TChar)) AND
                       (symtab [t.idx].lo # symtab [t.idx].hi) ;
         t.blo := symtab [t.idx].lo ; t.bhi := symtab [t.idx].hi ;
         IF t.cls = TSet THEN
            (* The identifier-statement path does not go through ParseVar, so
               it must carry the same set metadata: Assignment's set branch
               uses setsize/setbase to build the constructor. *)
            t.setoff := symtab [t.idx].off ;
            t.setbase := symtab [t.idx].elem ;
            t.setsize := symtab [t.idx].size
         END ;
         ParseSub (t) ;
         IF MatchAssign () THEN
            Assignment (t) ;
            RETURN
         END ;
         Err (ENoSemi) ;
         RETURN
      END ;
      Err (ENoSemi)
   END
END Statmnt ;

(* ---------------------------------------------------------------- *)
(*  types and declarations  (TPSRC7)                                *)
(* ---------------------------------------------------------------- *)

PROCEDURE ParseType (VAR cls, size, elem : CARDINAL) ;
VAR tok : CARDINAL ;
    idx : CARDINAL ;
    lo, hi : LONGINT ;
    s2, e2 : CARDINAL ;
    subcls : CARDINAL ;
    strf : BOOLEAN ;
    isCharRange : BOOLEAN ;
    consumed : BOOLEAN ;
    running, groupFirst, i, an, recStart : CARDINAL ;
    innerIdx, innerN, leafElem, leafCls, j : CARDINAL ;
    elemFldFirst, elemFldLast, fieldFldFirst, fieldFldLast, fieldArrIdx : CARDINAL ;
    elemType : CARDINAL ;
    elemLo, elemHi : LONGINT ;
    fieldPtrElem : CARDINAL ;
    variantBase, armRunning, armMax, savePosVar : CARDINAL ;
    moreFields : BOOLEAN ;
    tagName : ARRAY [0..MaxName] OF CHAR ;
    alo, ahi : ARRAY [0..3] OF LONGINT ;
    ecls2 : CARDINAL ;
BEGIN
   cls := TNone ; size := 0 ; elem := 0 ;
   consumed := FALSE ;
   newArrIdx := 0 ;
   Skip () ;                (* after ':' / '=' : skip blanks *)
   IF CurCh () = '^' THEN
      (* A pointer type: ^Type.  The pointer itself is a word; its `elem'
         field holds the pointee TYPE symbol, not a byte size.  The pointee's
         array/record metadata is copied onto the pointer variable so a
         dereference can hand it to ParseSub unchanged. *)
      DropCh (GetCh ()) ;
      Skip () ;
      IF NOT Alpha (CurCh ()) THEN
         Err (ESimpType) ;
         RETURN
      END ;
      GetWord () ;
      IF Search (wrd, idx) THEN
         IF symtab [idx].tag # KType THEN
            Err (ESimpType) ;
            RETURN
         END
      ELSE
         (* Forward type reference: `Next : ^Person' before the record is
            declared.  Create a placeholder that DefType will fill. *)
         idx := NewSym (wrd, KType, TNone, 0, 0, 0, 0, FALSE) ;
         symtab [idx].fwd := TRUE
      END ;
      cls := TPtr ;
      size := 2 ;
      elem := idx ;                       (* pointee type symbol *)
      newArrIdx := symtab [idx].arrIdx ;
      recFldFirst := symtab [idx].fldFirst ;
      recFldLast := symtab [idx].fldLast ;
      enumLo := symtab [idx].lo ;
      enumHi := symtab [idx].hi ;
      RETURN
   END ;
   IF CurCh () = '(' THEN
      (* An enumeration: `(Constant, Formula, Txt, ...)'.  Each enumerator
         becomes a constant with its ordinal position as its value, and the
         TYPE is 1 byte (TP3 uses one below 256 values) with bounds 0..n-1,
         which DefType records so `set of Attributes' can size its base.
         Enumerators are TScalar, not TEnum: they behave as ordinals; only the
         TYPE carries the enum identity and its bounds. *)
      DropCh (GetCh ()) ;
      lo := 0 ;
      hi := -1 ;
      LOOP
         Skip () ;
         IF NOT Alpha (CurCh ()) THEN
            Err (EUnknown) ;
            RETURN
         END ;
         GetWord () ;
         DupTest (wrd) ;
         DropC (NewSym (wrd, KConst, TScalar, 1, 1, 0, hi + 1, FALSE)) ;
         hi := hi + 1 ;
         IF MatchDelim (',') THEN
            (* another enumerator *)
         ELSE
            EXIT
         END
      END ;
      ExpectDelim (')', ENoSemi) ;
      enumLo := lo ;
      enumHi := hi ;
      cls := TEnum ;
      size := 1 ;
      elem := 1 ;
      RETURN
   END ;
   IF Alpha (CurCh ()) THEN
      DropB (MatchKey (tok)) ;
      consumed := TRUE
   ELSE
      tok := TkNone
   END ;
   IF tok = TkArray THEN
      (* array [range, range, ...] of T.  Several ranges are allowed; the LAST
         varies fastest (row-major), so `Sheet[fx,fy]' strides the first range
         by the second's count (RESUME-TP3.md §2).  The shape is kept in the
         array table; the symbol carries a pointer to it (SymEntry.arrIdx) so
         indexing can scale by the element size and subtract each lower bound. *)
      ExpectDelim ('[', ENoSemi) ;
      an := 0 ;
      LOOP
         Skip () ;
         IF Alpha (CurCh ()) THEN
            (* An enum/subrange TYPE as the index: `array[Standardfunction]'.
               Its bounds are on the type symbol. *)
            GetWord () ;
            IF NOT Search (wrd, idx) OR (symtab [idx].tag # KType)
               OR (symtab [idx].cls # TEnum) THEN
               Err (ESimpType) ;
               RETURN
            END ;
            lo := symtab [idx].lo ;
            hi := symtab [idx].hi
         ELSE
            RdConst (lo, subcls, strf) ;
            IF NOT MatchRange () THEN
               Err (ESimpType) ;
               RETURN
            END ;
            RdConst (hi, subcls, strf)
         END ;
         IF an < 4 THEN
            alo [an] := lo ;
            ahi [an] := hi ;
            INC (an)
         END ;
         IF MatchDelim (',') THEN
            (* another range *)
         ELSE
            EXIT
         END
      END ;
      ExpectDelim (']', ENoSemi) ;
      IF NOT (MatchKey (tok) AND (tok = TkOf)) THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      ParseType (cls, s2, e2) ;
      ecls2 := cls ;
      innerIdx := newArrIdx ;
      elemFldFirst := recFldFirst ;
      elemFldLast := recFldLast ;
      elemLo := enumLo ; elemHi := enumHi ;
      elemType := 0 ;
      IF cls = TPtr THEN
         elemType := e2
      END ;
      IF (cls = TArray) AND (innerIdx > 0) THEN
         (* Flatten array-of-array: the outer symbol must index the same
            number of dimensions as `array[a,b]'.  A named element array
            (`Airplane = array[...] of Dog_Food') carries its shape in the
            inner ArrRec; keep only the leaf element size and class here. *)
         leafElem := arrs [innerIdx - 1].elem ;
         leafCls := arrs [innerIdx - 1].ecls ;
         elemFldFirst := arrs [innerIdx - 1].fldFirst ;
         elemFldLast := arrs [innerIdx - 1].fldLast ;
         elemLo := arrs [innerIdx - 1].elemLo ;
         elemHi := arrs [innerIdx - 1].elemHi ;
         elemType := arrs [innerIdx - 1].elemType ;
         innerN := arrs [innerIdx - 1].n
      ELSE
         leafElem := s2 ;
         leafCls := ecls2 ;
         innerN := 0
      END ;
      cls := TArray ;
      elem := leafElem ;
      size := s2 ;
      i := 0 ;
      WHILE i < an DO
         size := size * W16 (VAL (LONGINT, W16 (ahi [i]))
                             - VAL (LONGINT, W16 (alo [i])) + 1) ;
         INC (i)
      END ;
      (* register the flattened shape so indexing can scale by leaf element
         size and subtract each lower bound; the symbol points at this slot *)
      IF (an + innerN <= 4) AND (arrTop < MaxArrs) THEN
         arrs [arrTop].n := an + innerN ;
         arrs [arrTop].elem := leafElem ;
         arrs [arrTop].ecls := leafCls ;
         arrs [arrTop].fldFirst := elemFldFirst ;
         arrs [arrTop].fldLast := elemFldLast ;
         arrs [arrTop].elemType := elemType ;
         arrs [arrTop].elemLo := elemLo ;
         arrs [arrTop].elemHi := elemHi ;
         i := 0 ;
         WHILE i < an DO
            arrs [arrTop].lo [i] := alo [i] ;
            arrs [arrTop].hi [i] := ahi [i] ;
            INC (i)
         END ;
         j := 0 ;
         WHILE j < innerN DO
            arrs [arrTop].lo [an + j] := arrs [innerIdx - 1].lo [j] ;
            arrs [arrTop].hi [an + j] := arrs [innerIdx - 1].hi [j] ;
            INC (j)
         END ;
         newArrIdx := arrTop + 1 ;
         INC (arrTop)
      ELSE
         Err (ECompOvf)
      END
   ELSIF tok = TkString THEN
      cls := TString ;
      size := 256 ;
      elem := 1 ;
      IF MatchDelim ('[') THEN
         RdConst (hi, subcls, strf) ;
         ExpectDelim (']', ENoSemi) ;
         size := W16 (hi) + 1
      END
   ELSIF tok = TkSet THEN
      (* set of <ordinal>.  TP3's hybrid layout (coeur-tp-ocr 4.7.2): only the
         whole BYTES covering the base range are stored, so `set of Char' is 32
         bytes and `set of 12..17' is 2.  `elem' carries the origin - the first
         element of the first byte, a multiple of 8 - which is all the
         membership and constructor arithmetic needs. *)
      PeekKw (tok) ;
      IF tok = TkOf THEN
         DropB (MatchKey (tok)) ;
         RdSetBase (subcls, lo, hi) ;
         IF OK () THEN
            cls := TSet ;
            elem := (VAL (CARDINAL, lo) DIV 8) * 8 ;
            size := (VAL (CARDINAL, hi) DIV 8)
                    - (VAL (CARDINAL, lo) DIV 8) + 1
         END
      ELSE
         Err (ENoSemi)
      END
   ELSIF tok = TkRecord THEN
      (* record  fieldList  end, fields NON-COMPACTED and juxtaposed
         (RESUME-TP3.md §2).  Each name in a `a, b : T' group is a field of its
         own at the running offset; the field table is where `x.f' looks, keyed
         per record so field names need not be globally unique.
         recFldFirst/recFldLast hand the range to DefType, or to the enclosing
         record's field entry when records nest. *)
      recStart := fldTop ;
      recFldFirst := fldTop ;
      running := 0 ;
      LOOP
         PeekKw (tok) ;
         IF tok = TkEnd THEN
            DropB (MatchKey (tok)) ;
            EXIT
         END ;
         IF CurCh () = 0C THEN
            Err (EUnknown) ;
            EXIT
         END ;
         IF tok = TkCase THEN
            (* Variant part: fields in all arms overlay at the same base.
               The tag, when named, is an ordinary field before the arms. *)
            DropB (MatchKey (tok)) ;
            Skip () ;
            tagName [0] := CHR (0) ;
            savePosVar := srcPos ;
            IF Alpha (CurCh ()) THEN
               GetWord () ;
               Skip () ;
               IF CurCh () = ':' THEN
                  CopyStr (tagName, wrd) ;
                  DropCh (GetCh ()) ;
                  ParseType (subcls, s2, e2) ;
                  IF OK () THEN
                     IF fldTop < MaxFields THEN
                        CopyStr (fields [fldTop].name, tagName) ;
                        fields [fldTop].cls := subcls ;
                        fields [fldTop].size := s2 ;
                        fields [fldTop].elem := e2 ;
                        fields [fldTop].off := running ;
                        fields [fldTop].fldFirst := recFldFirst ;
                        fields [fldTop].fldLast := recFldLast ;
                        fields [fldTop].arrIdx := newArrIdx ;
                        fields [fldTop].ptrElem := 0 ;
                        INC (fldTop) ;
                        running := running + s2
                     ELSE
                        Err (ECompOvf)
                     END
                  ELSE
                     RETURN
                  END
               ELSE
                  srcPos := savePosVar ;
                  ParseType (subcls, s2, e2) ;
                  IF NOT OK () THEN
                     RETURN
                  END
               END
            ELSE
               ParseType (subcls, s2, e2) ;
               IF NOT OK () THEN
                  RETURN
               END
            END ;
            IF NOT (MatchKey (tok) AND (tok = TkOf)) THEN
               Err (ENoSemi) ;
               RETURN
            END ;
            variantBase := running ;
            armMax := 0 ;
            LOOP
               Skip () ;
               PeekKw (tok) ;
               IF tok = TkEnd THEN
                  EXIT
               END ;
               RdConst (lo, subcls, strf) ;
               IF NOT MatchDelim (':') THEN
                  Err (ENoSemi) ;
                  RETURN
               END ;
               IF NOT MatchDelim ('(') THEN
                  Err (ENoSemi) ;
                  RETURN
               END ;
               armRunning := variantBase ;
               moreFields := TRUE ;
               WHILE moreFields AND (CurCh () # ')') DO
                  groupFirst := fldTop ;
                  LOOP
                     Skip () ;
                     IF NOT Alpha (CurCh ()) THEN
                        Err (EUnknown) ;
                        RETURN
                     END ;
                     GetWord () ;
                     IF fldTop < MaxFields THEN
                        CopyStr (fields [fldTop].name, wrd) ;
                        fields [fldTop].off := 0 ;
                        INC (fldTop)
                     ELSE
                        Err (ECompOvf)
                     END ;
                     IF NOT MatchDelim (',') THEN
                        EXIT
                     END
                  END ;
                  ExpectDelim (':', ENoSemi) ;
                  ParseType (subcls, s2, e2) ;
                  IF NOT OK () THEN
                     RETURN
                  END ;
                  fieldFldFirst := recFldFirst ;
                  fieldFldLast := recFldLast ;
                  fieldArrIdx := newArrIdx ;
                  fieldPtrElem := 0 ;
                  IF subcls = TPtr THEN
                     fieldPtrElem := e2
                  END ;
                  i := groupFirst ;
                  WHILE i < fldTop DO
                     fields [i].cls := subcls ;
                     fields [i].size := s2 ;
                     fields [i].elem := e2 ;
                     fields [i].off := armRunning ;
                     fields [i].lo := enumLo ;
                     fields [i].hi := enumHi ;
                     fields [i].fldFirst := fieldFldFirst ;
                     fields [i].fldLast := fieldFldLast ;
                     fields [i].arrIdx := fieldArrIdx ;
                     fields [i].ptrElem := fieldPtrElem ;
                     armRunning := armRunning + s2 ;
                     INC (i)
                  END ;
                  IF MatchDelim (';') THEN
                     (* another field group in this arm *)
                  ELSE
                     moreFields := FALSE
                  END
               END ;
               ExpectDelim (')', ENoSemi) ;
               IF armRunning - variantBase > armMax THEN
                  armMax := armRunning - variantBase
               END ;
               IF MatchDelim (';') THEN
                  (* another variant arm *)
               ELSE
                  EXIT
               END
            END ;
            running := variantBase + armMax ;
            (* the record's own END is read by the outer loop *)
         ELSE
         (* the group's names, then ONE `: type' *)
         groupFirst := fldTop ;
         LOOP
            Skip () ;
            IF NOT Alpha (CurCh ()) THEN
               Err (EUnknown) ;
               RETURN
            END ;
            GetWord () ;
            IF fldTop < MaxFields THEN
               CopyStr (fields [fldTop].name, wrd) ;
               fields [fldTop].off := 0 ;
               INC (fldTop)
            ELSE
               Err (ECompOvf)
            END ;
            IF NOT MatchDelim (',') THEN
               EXIT
            END
         END ;
         ExpectDelim (':', ENoSemi) ;
         ParseType (subcls, s2, e2) ;
         IF NOT OK () THEN
            RETURN
         END ;
         fieldFldFirst := recFldFirst ;
         fieldFldLast := recFldLast ;
         fieldArrIdx := newArrIdx ;
         fieldPtrElem := 0 ;
         IF subcls = TPtr THEN
            fieldPtrElem := e2
         END ;
         (* every name in the group gets the type and its own slot *)
         i := groupFirst ;
         WHILE i < fldTop DO
            fields [i].cls := subcls ;
            fields [i].size := s2 ;
            fields [i].elem := e2 ;
            fields [i].off := running ;
            fields [i].lo := enumLo ;
            fields [i].hi := enumHi ;
            fields [i].fldFirst := fieldFldFirst ;
            fields [i].fldLast := fieldFldLast ;
            fields [i].arrIdx := fieldArrIdx ;
            fields [i].ptrElem := fieldPtrElem ;
            running := running + s2 ;
            INC (i)
         END ;
         IF NOT MatchDelim (';') THEN
            Err (ENoSemi) ;
            RETURN
         END
         END ;                         (* the variant IF *)
      END ;                            (* the record field LOOP *)
      (* The field TYPES are parsed by ParseType, and its named-type arm
         copies the TYPE's field range into recFldFirst/recFldLast - for
         `Integer' that is 0/0.  So recFldFirst set at the top of this branch
         is overwritten by every field type.  It happens to be right for the
         FIRST record in a compile (fldTop is 0 then), and wrong for every
         later one: t77's second record started at 2 but recorded 0, which
         made a WITH field lookup scan the previous record's fields.  Restore
         the saved start here, after the last field type has been parsed. *)
      recFldFirst := recStart ;
      recFldLast := fldTop ;
      cls := TRecord ;
      size := running ;
      elem := running
   ELSIF tok = TkText THEN
      (* A TEXT file variable.  We do our own unbuffered INT 21h I/O, so the
         file variable is just our control block (see FileVarSize) and the
         element is one byte; TP3 keeps a 128-byte buffer in its own, which is
         a divergence we do not need. *)
      cls := TText ;
      size := FileVarSize ;
      elem := 1
   ELSIF tok = TkFile THEN
      (* `file' (untyped) or `file of T'.  The element type is parsed for its
         SIZE, which is what a Read/Write moves per record; the variable
         itself is always the control block.  CALC.INC's Exist declares
         `F : file', so the OF must be optional: requiring it produced ENoSemi
         at the declaration's semicolon, which was misread as the function
         declaration being unsupported.  TUntyp keeps the untyped file
         distinguishable, because a Read/Write through it has no element size
         and must stay refused. *)
      PeekKw (tok) ;
      IF tok = TkOf THEN
         DropB (MatchKey (tok)) ;
         ParseType (subcls, s2, e2) ;
         IF OK () THEN
            cls := TFile ;
            size := FileVarSize ;
            elem := s2
         END
      ELSE
         cls := TUntyp ;
         size := FileVarSize ;
         elem := 1
      END
   ELSE
      IF consumed THEN
         IF Search (wrd, idx) AND (symtab [idx].tag = KConst) THEN
            (* An enum/ordinal subrange written with named constants:
               `Work = Mon..Fri`.  Without this, `Mon' was mistaken for a
               named TYPE and failed at the first dot. *)
            lo := symtab [idx].lval ;
            subcls := symtab [idx].cls ;
            IF NOT MatchRange () THEN
               Err (ESimpType) ;
               RETURN
            END ;
            RdConst (hi, subcls, strf) ;
            IF NOT OK () THEN
               RETURN
            END ;
            cls := TEnum ;
            IF (lo >= 0) AND (hi <= 255) AND (lo <= hi) THEN
               size := 1
            ELSE
               size := 2
            END ;
            elem := size ;
            enumLo := lo ;
            enumHi := hi
         ELSIF Search (wrd, idx) AND (symtab [idx].tag = KType) THEN
            cls := symtab [idx].cls ;
            size := symtab [idx].size ;
            (* The type's ELEMENT size, not its total size.  They are equal for
               a record, but not for an array (`Letters' is 6 bytes of 3
               Integers) or a file.  A named array typed constant used to get
               typElem = 6, wrote six bytes per element and wrapped the
               little-endian divider to zero: SIGFPE in DefConst. *)
            elem := symtab [idx].elem ;
            enumLo := symtab [idx].lo ;
            enumHi := symtab [idx].hi ;
            recFldFirst := symtab [idx].fldFirst ;
            recFldLast := symtab [idx].fldLast ;
            newArrIdx := symtab [idx].arrIdx
         ELSE
            Err (EUnknown)
         END
      ELSE
         (* subrange lo .. hi.  TP3 sizes it by its bounds: ONE byte when both
            are inside 0..255, else two (RESUME-TP3.md §2).  `0..20' and
            `'A'..'G'' are one byte - which is what makes CellRec 80 and not
            82, and `Sheet' 147*80.  The bounds are kept for `set of T'. *)
         Skip () ;
         isCharRange := (ORD (CurCh ()) = AposC) OR (CurCh () = '^')
                        OR (CurCh () = '#') ;
         RdConst (lo, subcls, strf) ;
         IF NOT MatchRange () THEN
            Err (ESimpType) ;
            RETURN
         END ;
         RdConst (hi, subcls, strf) ;
         IF isCharRange THEN
            cls := TChar
         ELSE
            cls := TScalar
         END ;
         IF (lo >= 0) AND (hi <= 255) AND (lo <= hi) THEN
            size := 1
         ELSE
            size := 2
         END ;
         elem := size ;
         enumLo := lo ;
         enumHi := hi
      END
   END
END ParseType ;

PROCEDURE DefVar () ;
(* 'name' (',' name)* ':' type [ABSOLUTE addr] ; group repeated until a
   declaration keyword appears *)
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    cls, size, elem : CARDINAL ;
    tok : CARDINAL ;
    v : LONGINT ;
    off : CARDINAL ;
    first, i : CARDINAL ;
    segAbs : BOOLEAN ;
BEGIN
   LOOP
      Skip () ;                (* after the VAR keyword: skip blanks *)
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      (* A group is `name (, name)* : type' - TPSRC7 rdvarlst/rdvloop collects
         the whole comma-separated list of names FIRST (`CALL ccomma / JZ
         rdvloop'), then reads one `: type' with ecolon/rdvartp, then vardef2
         gives every name in the list that one type.  The names are created as
         placeholders here and filled in once the type is known, which is the
         same shape as TP3 reserving a symtab slot per name and storing the
         type pointer into each afterwards. *)
      first := symTop ;
      LOOP
         Skip () ;             (* GetWord does not skip blanks, and the cursor
                                  sits on the space after the ',' *)
         IF NOT Alpha (CurCh ()) THEN
            Err (EUnknown) ;
            RETURN
         END ;
         GetWord () ;
         SaveWord (nm) ;
         DupTest (nm) ;
         DropC (NewSym (nm, KVar, TNone, 0, 0, 0, 0, lexnest # 0)) ;
         IF NOT MatchDelim (',') THEN
            EXIT
         END
      END ;
      ExpectDelim (':', ENoSemi) ;
      ParseType (cls, size, elem) ;
      IF OK () THEN
         IF lexnest = 0 THEN
            IF (size > 2) AND (cls # TString) AND (cls # TRecord)
               AND (cls # TArray) AND (cls # TFile) AND (cls # TText)
               AND (cls # TUntyp) AND (cls # TReal) AND (cls # TSet) THEN
               (* Still the catch-all for a type whose storage this compiler does
                  not lay out yet (an ARRAY at its point of use, a RECORD, ...).
                  A STRING is the exception now: its layout is length byte +
                  characters, and the rest of the compiler knows it - see
                  Assignment and IoCall. *)
               Err (ENoLib) ;
               RETURN
            END ;
            PeekKw (tok) ;
            IF tok = TkAbsolute THEN
               DropB (MatchKey (tok)) ;
               Skip () ;
               segAbs := FALSE ;
               IF Alpha (CurCh ()) THEN
                  (* Turbo's `Cseg:$80' / `Dseg:$80'.  Our globals carry
                     LoadBias in their direct addresses, so subtract it from
                     the requested absolute address. *)
                  GetWord () ;
                  ExpectDelim (':', ENoSemi) ;
                  segAbs := TRUE
               END ;
               IF (CurCh () = '$') OR (Digit (CurCh ())) THEN
                  RdIntConst (v) ;
                  IF segAbs THEN
                     off := W16 (v - VAL (LONGINT, LoadBias))
                  ELSE
                     off := W16 (v)
                  END
               ELSE
                  Err (EUnknown) ;
                  off := 0
               END ;
               (* TP3's absolute path (vdstore) leaves the offset fixed, so
                  every name in the group aliases the same address. *)
               i := first ;
               WHILE i < symTop DO
                  symtab [i].cls := cls ; symtab [i].size := size ;
                  symtab [i].elem := elem ; symtab [i].off := off ;
                  symtab [i].lo := enumLo ; symtab [i].hi := enumHi ;
                  symtab [i].fldFirst := recFldFirst ;
                  symtab [i].fldLast := recFldLast ;
                  symtab [i].arrIdx := newArrIdx ;
                  INC (i)
               END
            ELSE
               i := first ;
               WHILE i < symTop DO
                  symtab [i].cls := cls ; symtab [i].size := size ;
                  symtab [i].elem := elem ; symtab [i].off := dc ;
                  symtab [i].lo := enumLo ; symtab [i].hi := enumHi ;
                  symtab [i].fldFirst := recFldFirst ;
                  symtab [i].fldLast := recFldLast ;
                  symtab [i].arrIdx := newArrIdx ;
                  dc := dc + size ;
                  INC (i)
               END
            END ;
            varspc := varspc + size * (symTop - first)
         ELSE
            PeekKw (tok) ;
            IF tok = TkAbsolute THEN
               DropB (MatchKey (tok)) ;
               Skip () ;
               segAbs := FALSE ;
               IF Alpha (CurCh ()) THEN
                  GetWord () ;
                  ExpectDelim (':', ENoSemi) ;
                  segAbs := TRUE
               END ;
               IF (CurCh () = '$') OR (Digit (CurCh ())) THEN
                  RdIntConst (v) ;
                  IF segAbs THEN
                     off := W16 (v - VAL (LONGINT, LoadBias))
                  ELSE
                     off := W16 (v)
                  END
               ELSE
                  Err (EUnknown) ;
                  off := 0
               END ;
               i := first ;
               WHILE i < symTop DO
                  symtab [i].cls := cls ; symtab [i].size := size ;
                  symtab [i].elem := elem ; symtab [i].off := off ;
                  symtab [i].lo := enumLo ; symtab [i].hi := enumHi ;
                  symtab [i].fldFirst := recFldFirst ;
                  symtab [i].fldLast := recFldLast ;
                  symtab [i].arrIdx := newArrIdx ;
                  symtab [i].local := FALSE ;
                  INC (i)
               END
            ELSE
            IF (size > 2) AND (cls # TString) AND (cls # TRecord)
               AND (cls # TArray) AND (cls # TFile) AND (cls # TText)
               AND (cls # TUntyp) AND (cls # TReal) AND (cls # TSet) THEN
               Err (ENoLib) ;
               RETURN
            END ;
            (* A local occupies [off, off+size-1] and lives BELOW the saved BP,
               because BP-relative locals grow down from the top of the frame
               while a STRING grows UP from its base (length byte, then chars).
               Top-anchored packing keeps both true at once: locFree is the
               highest still-free byte (-1 at the top), the new symbol's base
               is placed so that its LAST byte lands on that byte, and locFree
               then drops by the whole size.  So the first INTEGER (size 2) is
               at -2 and the second at -4, byte for byte what the old
               pre-decrement rule produced, while a string[5] local (size 6) is
               at -6..-1 instead of the old -2..+3 - which straddled the saved
               BP at [BP] and the return address at [BP+2] and made `readln(s)'
               into a local store characters over its own return address.
               Each name in the group gets its own slot. *)
            i := first ;
            WHILE i < symTop DO
               symtab [i].cls := cls ; symtab [i].size := size ;
               symtab [i].elem := elem ;
               symtab [i].lo := enumLo ; symtab [i].hi := enumHi ;
               symtab [i].fldFirst := recFldFirst ;
               symtab [i].fldLast := recFldLast ;
               symtab [i].arrIdx := newArrIdx ;
               symtab [i].off := (locFree - size + 1) MOD 10000H ;
               locFree := (locFree - size) MOD 10000H ;
               INC (i)
            END ;
            locBytes := locBytes + size * (symTop - first)
            END
         END
      END ;
      IF MatchDelim (',') THEN
         (* The older `name : type, name : type' spelling: another group
            follows without a semicolon.  TP3's grammar is names-then-one-type
            with ',' inside a group and ';' between groups (TPSRC7 rdvarlst /
            rdvloop then ecolon/rdvartp), and both spellings reach the same
            symbols, so both separators are accepted here. *)
      ELSIF MatchDelim (';') THEN
         PeekKw (tok) ;
         IF tok # TkNone THEN
            RETURN
         END
      ELSE
         Err (ENoSemi) ;
         RETURN
      END
   END
END DefVar ;

PROCEDURE DefConst () ;
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    v : LONGINT ;
    cls, typCls, typSize, typElem, soff, ci : CARDINAL ;
    isStr : BOOLEAN ;
    tok : CARDINAL ;
    typed, setTyped, arrTyped : BOOLEAN ;
    nb, k, divi, w, slen, eltCls : CARDINAL ;
BEGIN
   LOOP
      PeekKw (tok) ;
      IF tok # TkNone THEN
         RETURN
      END ;
      Skip () ;                (* after the CONST keyword: skip blanks *)
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      GetWord () ;
      SaveWord (nm) ;
      DupTest (nm) ;
      (* Two spellings: a plain constant `name = value', and a TYPED constant
         `name : Type = value', which TP3 3.0 added (TPSRC7's constant reader
         takes the type first and the value second).  For a SCALAR type the
         value still folds to an immediate, so the declared type is simply
         recorded as the symbol's class - `FXMax : Char = 'G'' is a TChar
         constant holding 71, and `writeln (FXMax)' prints G rather than 71.

         A SET typed constant (`Numbers : set of Char = ['0'..'9']') is a value
         with a layout, so it cannot fold: its bytes are emitted code-resident
         and the name becomes an addressable value.  See the storage decision
         in CALC-COMPILE.md.  An ARRAY or RECORD typed constant is still
         refused loudly - those layouts come later. *)
      typed := FALSE ;
      setTyped := FALSE ;
      arrTyped := FALSE ;
      Skip () ;
      IF CurCh () = ':' THEN
         DropCh (GetCh ()) ;
         ParseType (typCls, typSize, typElem) ;
         IF OK () THEN
            IF typCls = TSet THEN
               setTyped := TRUE
            ELSIF typCls = TArray THEN
               arrTyped := TRUE
            ELSIF typSize > 2 THEN
               Err (ENoLib)
            ELSE
               typed := TRUE
            END
         END
      END ;
      IF OK () AND setTyped THEN
         ExpectDelim ('=', ENoSemi) ;
         IF RdSetLiteral (typElem, typSize, constBlob) THEN
            soff := EmSetBlob (constBlob, typSize) ;
            DropC (NewSym (nm, KVar, TSet, typSize, typElem, soff, 0, FALSE))
         END
      ELSIF OK () AND arrTyped THEN
         (* array typed constant: `(v1, v2, ...)' in element order.  Integers
            are written little-endian in typElem bytes; a STRING element is
            <length><chars>.  CALC uses both XPOS (Integers) and
            StandardfunctionNames (string[6]). *)
         ExpectDelim ('=', ENoSemi) ;
         ExpectDelim ('(', ENoSemi) ;
         eltCls := 0 ;
         IF newArrIdx > 0 THEN
            eltCls := arrs [newArrIdx - 1].ecls
         END ;
         nb := 0 ;
         LOOP
            RdConst (v, cls, isStr) ;
            IF nb + typElem > 512 THEN
               Err (ECompOvf) ;
               EXIT
            END ;
            IF isStr OR ((eltCls = TString) AND (v >= 0) AND (v <= 255)) THEN
               (* A string element is <length><chars>, padded with NULs to
                  typElem bytes.  StandardfunctionNames is array of string[6].
                  A single-character literal ('I') is a TScalar, not a
                  string, so an array of STRING must still store it as a
                  one-character element.  Treating it as an integer divided
                  by 256 once per byte and hit DIV by zero at the fourth. *)
               IF isStr THEN
                  slen := strLen [rdStrX] ;
                  IF slen > typElem - 1 THEN
                     slen := typElem - 1
                  END
               ELSE
                  slen := 1
               END ;
               constBlob [nb] := CHR (slen) ;
               k := 0 ;
               WHILE k < typElem - 1 DO
                  IF k < slen THEN
                     IF isStr THEN
                        constBlob [nb + 1 + k] :=
                           strPool [strOff [rdStrX] + k]
                     ELSE
                        constBlob [nb + 1 + k] := CHR (v)
                     END
                  ELSE
                     constBlob [nb + 1 + k] := CHR (0)
                  END ;
                  INC (k)
               END ;
               nb := nb + typElem
            ELSIF typElem > 2 THEN
               (* An array of records/reals has no scalar encoding here.
                  Refuse loudly instead of shifting a 16-bit value through
                  divi until it wraps to zero and aborts the compiler. *)
               Err (ENoLib) ;
               EXIT
            ELSE
               w := VAL (CARDINAL, W16 (v)) ;
               divi := 1 ;
               k := 0 ;
               WHILE k < typElem DO
                  constBlob [nb] := CHR ((w DIV divi) MOD 256) ;
                  divi := divi * 256 ;
                  INC (nb) ;
                  INC (k)
               END
            END ;
            IF MatchDelim (',') THEN
               (* another element *)
            ELSE
               EXIT
            END
         END ;
         ExpectDelim (')', ENoSemi) ;
         IF OK () THEN
            soff := EmSetBlob (constBlob, typSize) ;
            ci := NewSym (nm, KVar, TArray, typSize, typElem, soff, 0, FALSE) ;
            symtab [ci].arrIdx := newArrIdx
         END
      ELSIF OK () THEN
         ExpectDelim ('=', ENoSemi) ;
         RdConst (v, cls, isStr) ;
         IF isStr THEN
            Err (ENoLib)
         END ;
         IF OK () THEN
            IF typed THEN
               cls := typCls
            END ;
            DropC (NewSym (nm, KConst, cls, 0, 0, 0, v, FALSE))
         END
      END ;
      IF NOT MatchDelim (';') THEN
         Err (ENoSemi) ;
         RETURN
      END
   END
END DefConst ;

PROCEDURE DefLabelPart () ;
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    n : CARDINAL ;
BEGIN
   LOOP
      Skip () ;
      IF Alpha (CurCh ()) THEN
         GetWord () ;
         SaveWord (nm)
      ELSIF Digit (CurCh ()) THEN
         n := 0 ;
         WHILE Digit (CurCh ()) DO
            n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ;
            DropCh (GetCh ())
         END ;
         NumToName (n, nm)
      ELSE
         Err (EUnknown) ;
         RETURN
      END ;
      IF NOT Search (nm, n) THEN
         DropC (NewSym (nm, KLabel, TScalar, 0, 0, 0, 0, FALSE))
      END ;
      IF NOT MatchDelim (',') THEN
         IF MatchDelim (';') THEN
            RETURN
         END ;
         Err (ENoSemi) ;
         RETURN
      END
   END
END DefLabelPart ;

PROCEDURE IfMatchSemi () ;
BEGIN
   IF NOT MatchDelim (';') THEN
      Err (ENoSemi)
   END
END IfMatchSemi ;

PROCEDURE SymEpi () ;
(* function result: AX := result var for a scalar, or copy six bytes to the
   caller's result scratch for a REAL function. *)
VAR k : CARDINAL ;
BEGIN
   IF curIsFunc THEN
      IF OK () THEN
         IF resultIsReal THEN
            EmLoadVar (TRUE, resultPtrOff, 2) ;
            EmMovDiAx () ;
            k := 0 ;
            WHILE k < 6 DO
               EmLoadVar (TRUE, symtab [resultVar].off + k, 1) ;
               EmStDiAlOff (k) ;
               INC (k)
            END
         ELSE
            LoadSymVar (resultVar, symtab [resultVar].off, symtab [resultVar].size)
         END
      END
   END
END SymEpi ;

PROCEDURE SlotSize (cls, size : CARDINAL) : CARDINAL ;
(* How many bytes a value parameter occupies in the callee's stack frame.
   TP3's `tstscal' (TPSRC7 1243): a scalar-like parameter is AT LEAST two
   bytes on the stack even when its type is one byte; anything larger spends
   its own size.  Generalised here so step 2 can put a string's 71 bytes on
   the stack without changing what a scalar does today. *)
BEGIN
   IF (cls = TScalar) OR (cls = TChar) OR (cls = TBool) OR (cls = TEnum) THEN
      RETURN 2
   END ;
   RETURN size
END SlotSize ;

PROCEDURE ParamSlotBytes (e : SymEntry) : CARDINAL ;
(* The bytes a parameter occupies in the frame.  A VAR parameter's slot is the
   ADDRESS, always two bytes, whatever its type: `size' stays the type's width
   so loads and stores know whether they read one byte or two. *)
BEGIN
   IF e.isVar THEN
      RETURN 2
   END ;
   RETURN SlotSize (e.cls, e.size)
END ParamSlotBytes ;

PROCEDURE ProcFunc () ;
(* PROCEDURE name (params) ; body | FUNCTION name (params) : type ; body *)
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    idx, old : CARDINAL ;
    tok, tok2 : CARDINAL ;
    parmNm : ARRAY [0..MaxName] OF CHAR ;
    cls, size, elem : CARDINAL ;
    isFunc, groupVar : BOOLEAN ;
    saveNest, saveLoc, saveRes, saveF : CARDINAL ;
    saveLB, savePO, saveRP : CARDINAL ;
    saveProc, saveStatic, staticOff : CARDINAL ;
    saveR : BOOLEAN ;
    realResult : BOOLEAN ;
    reusedFwd : BOOLEAN ;
    nestMark : CARDINAL ;             (* symTop just inside this procedure *)
    i, first : CARDINAL ;
BEGIN
   isFunc := curIsFunc ;
   Skip () ;                   (* after the PROCEDURE/FUNCTION keyword *)
   IF NOT Alpha (CurCh ()) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   GetWord () ;
   SaveWord (nm) ;
   IF Search (nm, idx) AND ((symtab [idx].tag = KProc)
      OR (symtab [idx].tag = KFunc)) AND (symtab [idx].fwd) THEN
      old := idx
   ELSIF Search (nm, idx) THEN
      Err (EUnknown) ;
      RETURN
   ELSE
      old := NewSym (nm, KProc, TNone, 0, 0, 0, 0, FALSE)
   END ;
   IF isFunc THEN
      symtab [old].tag := KFunc
   END ;
   saveProc := curProc ;
   saveStatic := curStaticOff ;
   symtab [old].parent := curProc ;
   curProc := old ;
   saveNest := lexnest ;
   saveLoc := locFree ;
   saveRes := resultVar ;
   saveF := VAL (CARDINAL, ORD (curIsFunc)) ;
   saveLB := locBytes ;
   savePO := parmOff ;
   saveRP := resultPtrOff ;
   saveR := resultIsReal ;
   INC (lexnest) ;
   nestMark := symTop ;          (* after the proc's own name, before its params *)
   locFree := 0FFFFH ;
   locBytes := 0 ;
   parmOff := 4 ;
   IF MatchDelim ('(') THEN
      IF CurCh () # ')' THEN
         LOOP
            (* PeekKw, not MatchKey: MatchKey CONSUMES the word it reads, so
               using it to test for VAR would eat the parameter's name. *)
            PeekKw (tok) ;
            groupVar := FALSE ;
            IF tok = TkVar THEN
               (* A by-reference parameter: the slot will hold an ADDRESS.
                  `size' still carries the type's own width, because the
                  callee's loads and stores must know whether they move one
                  byte or two. *)
               DropB (MatchKey (tok)) ;
               groupVar := TRUE
            END ;
            first := symTop ;
            LOOP
               Skip () ;          (* blanks before the parameter name *)
               IF NOT Alpha (CurCh ()) THEN
                  Err (EUnknown) ;
                  RETURN
               END ;
               GetWord () ;
               SaveWord (parmNm) ;
               DupTest (parmNm) ;
               DropC (NewSym (parmNm, KVar, TNone, 0, 0, 0, 0, TRUE)) ;
               IF NOT MatchDelim (',') THEN
                  EXIT
               END
            END ;
            ExpectDelim (':', ENoSemi) ;   (* formal is 'name : type' *)
            ParseType (cls, size, elem) ;
            IF groupVar AND (size > 2) AND (cls # TString) AND (cls # TReal) THEN
               (* A VAR parameter of a record or array would need the callee
                  to address through a larger object than the scalar [BX]
                  paths; refusing is the honest answer.  VAR STRING and VAR
                  REAL are the exceptions: both slots are two-byte ADDRESSES,
                  and both value types already have address-based runtime
                  paths. *)
               Err (ENoLib) ;
               RETURN
            END ;
            IF (size > 2) AND (cls # TString) AND (cls # TReal) THEN
               (* A string VALUE parameter is a whole-slot copy (n+1 bytes on
                  the stack); any other type wider than a word - a record, an
                  array, a set - is still refused.  A VAR REAL is allowed:
                  its slot is an address, not the six bytes. *)
               Err (ENoLib) ;
               RETURN
            END ;
            i := first ;
            WHILE i < symTop DO
               symtab [i].cls := cls ; symtab [i].size := size ;
               symtab [i].elem := elem ;
               symtab [i].lo := enumLo ; symtab [i].hi := enumHi ;
               symtab [i].off := parmOff ;
               symtab [i].isVar := groupVar ;
               IF groupVar THEN
                  parmOff := parmOff + 2      (* the address, whatever the type *)
               ELSE
                  parmOff := parmOff + SlotSize (cls, size)
               END ;
               INC (i)
            END ;
            IF MatchDelim (')') THEN
               EXIT
            END ;
            IF MatchDelim (';') THEN
               (* next group *)
            ELSIF MatchDelim (',') THEN
               (* the older `name : type, name : type' spelling *)
            ELSE
               Err (ENoSemi) ;
               EXIT
            END
         END
      ELSE
         DropCh (GetCh ())
      END
   END ;
   (* TP3 lays a parameter list out BACKWARDS from BP+4: the LAST declared
      parameter sits at BP+4 and each earlier one is 2 bytes farther from BP
      (RESUME-TP3.md 3.11 - "le dernier paramètre déclaré est le plus proche
      (BP+4)" - and the Code Generation Internals stack frame, "BP+4: last
      parameter").  This is the other half of pushing the arguments as they
      are parsed: the first argument is pushed first and so ends up farthest
      from BP, which has to be the FIRST declared parameter's slot.

      During the loop the offsets were provisional, in declaration order
      (parmOff starts at 4 and grows by each parameter's SLOT size), so
      parameter k sat at 4 + sum of the slots before it.  For slot sizes s and
      frame total T, the parameter's final base is
      4 + (T - prefix - s) = 8 + T - off - s, which sends the FIRST declared
      parameter to the far end and the LAST to BP+4.  With every slot 2 -
      every scalar, which is all this compiler accepts today - that reduces
      exactly to the old `parmOff + 2 - off`, so no existing frame moves.
      A slot larger than 2 (a string's 71 bytes) falls out of the same
      formula, and a VAR parameter is exactly 2 even when its TYPE is one
      byte: ParamSlotBytes carries that rule.

      The range is exactly the parameters: the only symbol created while the
      list is read is the parameter itself (NewSym inside the loop),
      ParseType creates no symbols, the procedure's own name predates
      nestMark, and a function's result variable is created after this point. *)
   i := nestMark ;
   WHILE i < symTop DO
      symtab [i].off := 8 + (parmOff - 4) - symtab [i].off
                        - ParamSlotBytes (symtab [i]) ;
      INC (i)
   END ;
   (* Record the parameter list on the procedure symbol: a call site has to
      know each argument's SLOT size to push and clean up the right number of
      bytes.  Only when this definition actually read a list - a FORWARD's
      list is kept, and the later `function Expression;' that repeats only the
      name must not wipe it. *)
   IF symTop > nestMark THEN
      symtab [old].parmFirst := nestMark ;
      symtab [old].parmCount := symTop - nestMark
   END ;
   (* TP3 lets the definition of a forward repeat only the name.  CALC writes
      `function Expression{(...):Real;forward};` -- the parameter list is in a
      comment, but the body still uses ExpressionCh.  The forward's formal
      symbols are still in the table (HideLocals only changed their level), so
      make exactly that range visible for this body again. *)
   reusedFwd := FALSE ;
   IF (symTop = nestMark) AND symtab [old].fwd
      AND (symtab [old].parmCount > 0) THEN
      i := symtab [old].parmFirst ;
      WHILE i < symtab [old].parmFirst + symtab [old].parmCount DO
         symtab [i].level := lexnest ;
         INC (i)
      END ;
      reusedFwd := TRUE
   END ;
   realResult := FALSE ;
   IF isFunc THEN
      IF MatchDelim (':') THEN
         ParseType (cls, size, elem)
      ELSIF symtab [old].fwd AND (symtab [old].cls # TNone) THEN
         (* The definition of a forward repeats only the name; inherit the
            result type declared by the forward. *)
         cls := symtab [old].cls ;
         size := symtab [old].size ;
         elem := symtab [old].elem
      ELSE
         cls := TScalar ;
         size := 2 ;
         elem := 2
      END ;
      IF (size > 2) AND (cls # TReal) THEN
         Err (ENoLib) ;
         RETURN
      END ;
      symtab [old].cls := cls ;
      symtab [old].size := size ;
      resultVar := NewSym (nm, KVar, cls, size, elem,
                           (locFree - size + 1) MOD 10000H, 0, TRUE) ;
      symtab [old].resvar := resultVar ;
      symtab [resultVar].resvar := old ;   (* reverse link for self-calls *)
      locFree := (locFree - size) MOD 10000H ;
      locBytes := locBytes + size ;
      resultIsReal := (cls = TReal) ;
      IF resultIsReal THEN
         (* Hidden two-byte local holding the caller's result destination.
            The caller passes it in DI before the CALL. *)
         resultPtrOff := (locFree - 1) MOD 10000H ;
         locFree := (locFree - 2) MOD 10000H ;
         locBytes := locBytes + 2
      ELSE
         resultPtrOff := 0
      END
   END ;
   IfMatchSemi () ;
   PeekKw (tok2) ;
   IF (tok2 = TkForward) OR (tok2 = TkExternal) THEN
      DropB (MatchKey (tok2)) ;
      symtab [old].fwd := TRUE ;
      symtab [old].defnd := (tok2 = TkExternal) ;
      IfMatchSemi () ;
      HideLocals (nestMark) ;      (* a FORWARD's parameters are not the
                                      caller's to see either *)
      lexnest := saveNest ;
      locFree := saveLoc ;
      resultVar := saveRes ;
      resultIsReal := saveR ;
      resultPtrOff := saveRP ;
      curIsFunc := (saveF # 0) ;
      locBytes := saveLB ;
      parmOff := savePO ;
      curProc := saveProc ;
      curStaticOff := saveStatic ;
      RETURN
   END ;
   (* A procedure declared inside another one receives its lexical parent's
      frame in DX.  Reserve a hidden local for it before ordinary locals, so
      nested code can walk the static chain.  Top-level procedures have no
      parent frame and no slot. *)
   IF symtab [old].level > 0 THEN
      staticOff := (locFree - 1) MOD 10000H ;
      locFree := (locFree - 2) MOD 10000H ;
      locBytes := locBytes + 2 ;
      symtab [old].staticOff := staticOff ;
      curStaticOff := staticOff
   ELSE
      staticOff := 0 ;
      curStaticOff := 0
   END ;
   (* Body.  Nested procedures are emitted BEFORE the enclosing procedure's
      prologue: otherwise execution entering the outer procedure falls straight
      through the nested bodies.  The outer entry point is therefore set only
      after DefPart has emitted them. *)
   DefPart () ;                       (* nested declarations; stops at BEGIN *)
   symtab [old].goPos := pc ;
   symtab [old].defnd := TRUE ;
   EmPushBp () ;
   EmMovBpSp () ;
   IF symtab [old].level > 0 THEN
      (* The caller passed the parent frame in DX. *)
      EmMovAxDx () ;
      EmStoreVar (TRUE, staticOff, 2)
   END ;
   IF resultIsReal THEN
      (* The caller put the six-byte result destination in DI.  Save it
         before declarations/body can reuse DI. *)
      EmMovAxDi () ;
      EmStoreVar (TRUE, resultPtrOff, 2)
   END ;
   IF locBytes > 0 THEN
      EmSubSp (locBytes)
   END ;
   DropC (EmCall (TU_StackChk)) ;
   Statmnt () ;                       (* body *)
   IF OK () THEN
      SymEpi () ;
      EmLeave () ;
      EmRet ()
   END ;
   (* patch pending forward calls to this proc *)
   i := 0 ;
   WHILE i < nPend DO
      IF (pend [i].kind = 1) AND (pend [i].who = old) THEN
         SetPatTgt (pend [i].place, symtab [old].goPos) ;
         pend [i].kind := 99
      END ;
      INC (i)
   END ;
   HideLocals (nestMark) ;         (* parameters and locals stop here *)
   IF reusedFwd THEN
      (* Hide only the forward's parameter range.  HideLocals starts at
         parmFirst and would also hide every procedure declared between the
         forward and its definition; t120's `B' disappeared when A was
         defined that way. *)
      i := symtab [old].parmFirst ;
      WHILE i < symtab [old].parmFirst + symtab [old].parmCount DO
         symtab [i].level := 0FFFFH ;
         INC (i)
      END
   END ;
   lexnest := saveNest ;
   locFree := saveLoc ;
   resultVar := saveRes ;
   resultIsReal := saveR ;
   resultPtrOff := saveRP ;
   curIsFunc := (saveF # 0) ;
   locBytes := saveLB ;
   parmOff := savePO ;
   curProc := saveProc ;
   curStaticOff := saveStatic
END ProcFunc ;

PROCEDURE DefType () ;
(* 'name' '=' typeDef ; ... until a declaration keyword appears *)
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    cls, size, elem, tidx : CARDINAL ;
    tok : CARDINAL ;
BEGIN
   LOOP
      PeekKw (tok) ;
      IF tok # TkNone THEN
         RETURN
      END ;
      Skip () ;                (* after the TYPE keyword: skip blanks *)
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      GetWord () ;
      SaveWord (nm) ;
      (* A type name may already exist as a forward placeholder created by
         `Next : ^Person' before `Person = record'.  Reuse that entry; only a
         real duplicate is an error. *)
      IF Search (nm, tidx) AND (symtab [tidx].tag = KType)
         AND (symtab [tidx].cls = TNone) THEN
         (* fill the placeholder below *)
      ELSE
         DupTest (nm) ;
         tidx := NewSym (nm, KType, TNone, 0, 0, 0, 0, FALSE)
      END ;
      ExpectDelim ('=', ENoSemi) ;
      ParseType (cls, size, elem) ;
      IF NOT OK () THEN
         RETURN
      END ;
      symtab [tidx].cls := cls ;
      symtab [tidx].size := size ;
      symtab [tidx].elem := elem ;
      symtab [tidx].fwd := FALSE ;
      IF (cls = TEnum) OR (cls = TChar) OR (cls = TScalar) THEN
         (* Enumeration and scalar/CHAR subrange bounds, set by ParseType. *)
         symtab [tidx].lo := enumLo ;
         symtab [tidx].hi := enumHi
      END ;
      IF cls = TRecord THEN
         (* and a record's fields live in the field table; the type records
            which range is its own *)
         symtab [tidx].fldFirst := recFldFirst ;
         symtab [tidx].fldLast := recFldLast
      END ;
      IF cls = TArray THEN
         symtab [tidx].arrIdx := newArrIdx ;
         (* ...and the ELEMENT's field table, if it is a record.  A variable
            declared `Sheet : Cells' gets its field metadata through the named
            type; without this, `Sheet[I,J].Field' and `with Sheet[I,J]' found
            fldFirst = fldLast = 0 and reported "not a record".  An INLINE
            `array ... of Rec' worked because ParseType's element call left
            the globals set for DefVar; the named form had lost them. *)
         symtab [tidx].fldFirst := recFldFirst ;
         symtab [tidx].fldLast := recFldLast
      END ;
      DropC (tidx) ;
      IF NOT MatchDelim (';') THEN
         Err (ENoSemi) ;
         RETURN
      END
   END
END DefType ;

PROCEDURE DefPart () ;
(* LABEL / CONST / TYPE / VAR / OVERLAY / PROC / FUNCTION / BEGIN *)
VAR tok : CARDINAL ;
BEGIN
   LOOP
      IF MatchDelim (';') THEN
         (* separator between declarations *)
      ELSE
         PeekKw (tok) ;
         IF tok = TkBegin THEN
            RETURN
         END ;
         IF NOT MatchKey (tok) THEN
            Err (EUnknown) ;
            RETURN
         END ;
         CASE tok OF
            TkLabel  : DefLabelPart () ;
         |  TkConst  : DefConst () ;
         |  TkType   : DefType () ;
         |  TkVar    : DefVar () ;
         |  TkOverlay :
               LOOP
                  Skip () ;
               IF CurCh () = ';' THEN
                     DropCh (GetCh ()) ;
                     EXIT
               END ;
                  IF CurCh () = 0C THEN
                     Err (ENoSemi) ;
                     EXIT
                  END ;
                  DropCh (GetCh ())
               END ;
         |  TkProcedure : curIsFunc := FALSE ; ProcFunc () ;
         |  TkFunction : curIsFunc := TRUE ; ProcFunc () ;
         ELSE
            Err (EUnknown) ;
            RETURN
         END ;
         IF NOT OK () THEN
            RETURN
         END
      END
   END
END DefPart ;

(* ---------------------------------------------------------------- *)
(*  driver  (TPSRC7 compile)                                        *)
(* ---------------------------------------------------------------- *)

PROCEDURE DefBuiltins () ;
(* The standard procedures.  Without these, WRITELN is absent from the
   symbol table, Statmnt's identifier branch fails its Search and every
   program that prints anything dies with EUnknown (41) on the '(' after the
   call name - the single remaining cause of failure in the fixture matrix.

   Tagged KBuiltin (not KProc) because these are not called generically:
   WRITE/WRITELN/READ/READLN need TP3's per-argument type dispatch
   (IoCall), and HALT takes no argument at all.  defnd is TRUE because the
   entry point is known - there is no forward reference to patch. *)
VAR i : CARDINAL ;
BEGIN
   i := NewSym ("WRITE"  , KBuiltin, BI_Write  , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   symtab [i].goPos := TU_WrInt ;
   i := NewSym ("WRITELN", KBuiltin, BI_WriteLn, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   symtab [i].goPos := TU_WrInt ;
   i := NewSym ("READ"   , KBuiltin, BI_Read   , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   symtab [i].goPos := TU_RdInt ;
   i := NewSym ("READLN" , KBuiltin, BI_ReadLn , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   symtab [i].goPos := TU_RdInt ;
   i := NewSym ("HALT"   , KBuiltin, BI_Halt   , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   symtab [i].goPos := TU_Halt ;
   i := NewSym ("LENGTH" , KBuiltin, BI_Length , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   symtab [i].goPos := 0 ;          (* inline: the length byte, no entry *)
   (* The CRT identifiers.  ClrScr and GotoXY emit real INT 10h code; the other
      four are registered so they are recognised, and IoCall refuses them with
      ENoLib - loud, not inert. *)
   i := NewSym ("CLRSCR"  , KBuiltin, BI_ClrScr  , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("GOTOXY"  , KBuiltin, BI_GotoXY  , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("LOWVIDEO", KBuiltin, BI_LowVideo, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("NORMVIDEO", KBuiltin, BI_NormVideo, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("CLREOL" , KBuiltin, BI_ClrEol  , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("DELAY"  , KBuiltin, BI_Delay   , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("KEYPRESSED", KBuiltin, BI_KeyPressed, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("UPCASE", KBuiltin, BI_UpCase, 0, 0, 0, 0, FALSE) ;
   i := NewSym ("ORD", KBuiltin, BI_Ord, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("ROUND", KBuiltin, BI_Round, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("TRUNC", KBuiltin, BI_Trunc, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("MSDOS", KBuiltin, BI_Msdos, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("INTR", KBuiltin, BI_Intr, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("GETDIR", KBuiltin, BI_GetDir, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("SEG", KBuiltin, BI_Seg, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("OFS", KBuiltin, BI_Ofs, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("POS", KBuiltin, BI_Pos, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("CONCAT", KBuiltin, BI_Concat, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("RANDOM", KBuiltin, BI_Random, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("RANDOMIZE", KBuiltin, BI_Randomize, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("FILLCHAR", KBuiltin, BI_FillChar, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("MOVE", KBuiltin, BI_Move, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("SEEK", KBuiltin, BI_Seek, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("FILEPOS", KBuiltin, BI_FilePos, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("FILESIZE", KBuiltin, BI_FileSize, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("ERASE", KBuiltin, BI_Erase, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("RENAME", KBuiltin, BI_Rename, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("BLOCKREAD", KBuiltin, BI_BlockRead, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("BLOCKWRITE", KBuiltin, BI_BlockWrite, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("SIZEOF", KBuiltin, BI_SizeOf, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("SUCC", KBuiltin, BI_Succ, 0, 0, 0, 0, FALSE) ;
   i := NewSym ("PRED", KBuiltin, BI_Pred, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   (* File operations.  These are the names CALC actually uses; Eof, not
      EndOfFile, because CALC declares a variable called EndOfFile. *)
   i := NewSym ("ASSIGN", KBuiltin, BI_Assign, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("RESET", KBuiltin, BI_Reset, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("REWRITE", KBuiltin, BI_Rewrite, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("CLOSE", KBuiltin, BI_Close, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("IORESULT", KBuiltin, BI_IoResult, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("CHR", KBuiltin, BI_Chr, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("STR", KBuiltin, BI_Str, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("NEW", KBuiltin, BI_New, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("DISPOSE", KBuiltin, BI_Dispose, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("EOF", KBuiltin, BI_Eof, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("VAL", KBuiltin, BI_Val, 0, 0, 0, 0, FALSE) ;
   DropC (i) ;
   i := NewSym ("COPY", KBuiltin, BI_Copy, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("ABS", KBuiltin, BI_Abs, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("SQRT", KBuiltin, BI_Sqrt, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("SQR", KBuiltin, BI_Sqr, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("LN", KBuiltin, BI_Ln, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("EXP", KBuiltin, BI_Exp, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("SIN", KBuiltin, BI_Sin, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("COS", KBuiltin, BI_Cos, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("ARCTAN", KBuiltin, BI_Arctan, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("INT", KBuiltin, BI_Int, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("DELETE", KBuiltin, BI_Delete, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   i := NewSym ("INSERT", KBuiltin, BI_Insert, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   (* KBD: the console keyboard as a TEXT file.  This runtime's read entries
      already read the console, so `Read(Kbd, Ch)' drops the file argument and
      reads a character exactly as `Read(Ch)' does. *)
   i := NewSym ("KBD", KVar, TText, FileVarSize, 1, 0, 0, FALSE) ;
   symtab [i].isKbd := TRUE ;
   (* LST is TP3's printer device.  The corpus uses it for listings; define
      the identifier as a TEXT variable so Write(Lst, ...) type-checks. *)
   i := NewSym ("LST", KVar, TText, FileVarSize, 1, 0, 0, FALSE)
END DefBuiltins ;

PROCEDURE Inittur () ;
(* reset compiler state and define the standard types *)
VAR i, rt : CARDINAL ;
BEGIN
   abortFac := FALSE ;
   errNum := 0 ;
   txerrPos := 0 ;
   srcPos := 0 ;
   srcLen := Length () ;
   inclActive := FALSE ;
   inclEnd := 0 ;
   (* The image layout is

          [JMP rel16][runtime][program header][program code]

      The runtime is copied to the front, which is what the original does:
      TPSRC7 "copyrt" runs REPZ MOVSB with SI=DI=0 and then "MOV pc,#$2D7C".
      Because the runtime sits at (near) offset 0, every address the compiler
      emits is already image-absolute - the data symbols' offsets, the TU_*
      call targets and the rel16 displacements all need no relocation pass.
      (The base shift would in fact cancel in EmCall's arithmetic, since both
      sides of a CALL move together; making the offsets absolute just means
      the linker has nothing to do but copy bytes.)

      The JMP is new, and it is not cosmetic.  A DOS .COM is entered at
      CS:0100, i.e. FILE offset 0, and for a long time offset 0 held the
      runtime's first bytes - so a .COM built by this compiler started by
      executing initmem with AX holding whatever the loader left in it.  Every
      test up to that point checked bytes and never ran the thing, so it could
      not see this.  The jump is the program's entry and the runtime is
      ordinary data to it; keeping the runtime at the front is what preserves
      the no-relocation property, so the jump goes in front of the runtime
      rather than the runtime being moved behind the program.

      dc is put a fixed 4 KiB above the end of the program so that data cannot
      collide with code in a single 64 KiB .COM segment.  LIMITATION: a
      program whose code exceeds 4 KiB overruns its own data area.  TP3 had
      overlay segments for this; we do not, and the check belongs where the
      limit is documented rather than as a silent truncation. *)
   RT_Build (EntSize) ;
   rt := RT_Size () ;
   IF rt >= MaxCode THEN
      Err (EMemOvf) ;                 (* cannot happen: rt is 436 *)
      RETURN
   END ;
   (* The entry jump, at image offset 0.  See the layout note above: a DOS
      .COM is entered at CS:0100, which is file offset 0, so whatever sits
      at offset 0 is the program's first executed instruction. *)
   (* The jump's three bytes are written out longhand rather than through
      Eword, because Eword writes at pc and advances it, and pc is stale at
      this point -- the operand landed wherever the last compile left pc. *)
   cbuf [0] := 0E9H ;                  (* JMP rel16 *)
   entRel := 1 ;
   cbuf [entRel] := 0 ;
   cbuf [entRel + 1] := 0 ;
   i := EntSize ;
   WHILE i - EntSize < rt DO
      cbuf [i] := RT_Byte (i - EntSize) ;
      INC (i)
   END ;
   pc := rt + EntSize ;
   rtSz := rt + EntSize ;
   dataBase := DataStart ;
   dc := dataBase ;
   imgReady := TRUE ;
   strTop := 0 ;
   strCnt := 0 ;
   rdStrX := 0 ;
   varspc := 0 ;
   symTop := 0 ;
   (* Per-compile tables.  They used to survive into the next file when the
      driver compiles several in one process (the compile matrix does exactly
      that): array indices kept growing, and a record's field range could be
      read against a stale table.  One compile must not depend on the last. *)
   fldTop := 0 ;
   arrTop := 0 ;
   withN := 0 ;
   nPatch := 0 ;
   nPend := 0 ;
   exitCnt := 0 ;
   brkN := 0 ;
   caseN := 0 ;
   lexnest := 0 ;
   curProc := 0 ;
   curStaticOff := 0 ;
   curIsFunc := FALSE ;
   resultVar := 0 ;
   resultIsReal := FALSE ;
   resultPtrOff := 0 ;
   callScratch := 0 ;
   locFree := 0FFFFH ;
   locBytes := 0 ;
   parmOff := 4 ;
   dirs.rng := FALSE ;
   dirs.chk := TRUE ;
   InitKeys () ;
   DropC (NewSym ("INTEGER", KType, TScalar, 2, 2, 0, 0, FALSE)) ;
   DropC (NewSym ("BYTE"   , KType, TScalar, 1, 1, 0, 0, FALSE)) ;
   DropC (NewSym ("CHAR"   , KType, TChar, 1, 1, 0, 0, FALSE)) ;
   DropC (NewSym ("BOOLEAN", KType, TBool  , 1, 1, 0, 0, FALSE)) ;
   DropC (NewSym ("REAL"   , KType, TReal  , 6, 6, 0, 0, FALSE)) ;
   DropC (NewSym ("STRING" , KType, TString, 256, 1, 0, 0, FALSE)) ;
   DropC (NewSym ("TRUE"   , KConst, TBool, 1, 1, 0, 1, FALSE)) ;
   DropC (NewSym ("FALSE"  , KConst, TBool, 1, 1, 0, 0, FALSE)) ;
   (* TP3's absolute byte array `Mem[address]'.  The base is chosen so the
      normal LoadBias addition lands on absolute offset zero. *)
   arrs [0].n := 1 ; arrs [0].elem := 1 ; arrs [0].ecls := TScalar ;
   arrs [0].lo [0] := 0 ; arrs [0].hi [0] := 65535 ;
   arrs [0].fldFirst := 0 ; arrs [0].fldLast := 0 ; arrs [0].elemType := 0 ;
   i := NewSym ("MEM", KVar, TArray, 65535, 1,
                W16 (-VAL (LONGINT, LoadBias)), 0, FALSE) ;
   symtab [i].arrIdx := 1 ;
   arrTop := 1 ;
   i := NewSym ("PORT", KVar, TArray, 1, 1, 0, 0, FALSE) ;
   symtab [i].isPort := TRUE ;
   DefBuiltins () ;
   tmpA := NewSym ("@@T1", KVar, TScalar, 2, 2, dc, 0, FALSE) ;
   dc := dc + 2 ;
   tmpB := NewSym ("@@T2", KVar, TScalar, 2, 2, dc, 0, FALSE) ;
   dc := dc + 2 ;
   (* The text attribute LowVideo/NormVideo set (default 7, written by the
      prologue).  One byte, and its address is baked into the clear sequences. *)
   crtAttrOff := dc ;
   DropC (NewSym ("@@ATTR", KVar, TScalar, 1, 1, dc, 0, FALSE)) ;
   dc := dc + 1 ;
   (* Runtime entry offsets, derived from the blob rather than assumed.  This
      has to happen after RT_Build, since RT_Entry only knows where the code
      landed once the blob is assembled.

      RT_Entry returns an IMAGE-ABSOLUTE address, already biased by the base
      RT_Build was given, so nothing here has to know where the runtime
      landed.  It used to return a blob-relative offset, and the bias was
      applied here instead - three bytes' worth, for the entry jump.  With
      that line missing, every CALL landed three bytes short, in the middle of
      a neighbouring runtime entry, and a CALL into the middle of wrtin's
      `INT 21h' behaves perfectly plausibly: the program runs, prints nothing
      and hangs.  Only running it finds that. *)
   IF (RT_Entry (13) = 0) OR (RT_Entry (11) = 0) OR (RT_Entry (3) = 0) THEN
      (* RT_Entry returns 0 for an unknown selector.  initmem sits at 0
         legitimately, so it cannot appear in this test - but wrtinl, rdln
         and wrint never can, so catching them is enough to catch a runtime
         that failed to build or a selector that went stale.  This test is on
         0 is not a usable address here, since RT_Entry returns an
         image-absolute address and the base is EntSize. *)
      Err (EMemOvf)
   END ;
   TU_InitMem  := RT_Entry (0) ;
   TU_ProgEnd  := RT_Entry (1) ;
   TU_StackChk := RT_Entry (2) ;
   TU_WrInt    := RT_Entry (3) ;
   TU_WrChar   := RT_Entry (4) ;
   TU_WrBool   := RT_Entry (5) ;
   TU_WrCharW  := RT_Entry (56) ;
   TU_WrBoolW  := RT_Entry (57) ;
   TU_WrStrW   := RT_Entry (58) ;
   TU_MemCopy  := RT_Entry (59) ;
   TU_RealToInt := RT_Entry (60) ;
   TU_Msdos    := RT_Entry (61) ;
   TU_GetDir   := RT_Entry (64) ;
   TU_StrPos   := RT_Entry (68) ;
   TU_Randomize := RT_Entry (69) ;
   TU_Random   := RT_Entry (70) ;
   TU_FillChar := RT_Entry (71) ;
   TU_Move     := RT_Entry (72) ;
   TU_Seek     := RT_Entry (73) ;
   TU_FilePos  := RT_Entry (74) ;
   TU_FileSize := RT_Entry (75) ;
   TU_Erase    := RT_Entry (76) ;
   TU_Rename   := RT_Entry (77) ;
   TU_BlockRead := RT_Entry (78) ;
   TU_BlockWrite := RT_Entry (79) ;
   TU_RunErr   := RT_Entry (80) ;
   TU_StrIndex := RT_Entry (81) ;
   TU_WrReal   := RT_Entry (6) ;
   TU_RealWrite := RT_Entry (30) ;     (* fmtreal + padding + output *)
   TU_RealFmt   := RT_Entry (28) ;     (* fmtreal into a string variable *)
   TU_RealVal   := RT_Entry (29) ;     (* ascreal: ASCIIZ -> REAL *)
   TU_RealCmp   := RT_Entry (26) ;     (* recmp: AX = -1/0/+1 *)
   TU_RealAdd   := RT_Entry (22) ;
   TU_RealFromInt := RT_Entry (21) ;
   TU_RealSub   := RT_Entry (23) ;
   TU_RealMul   := RT_Entry (24) ;
   TU_RealDiv   := RT_Entry (25) ;
   TU_WrLn     := RT_Entry (7) ;
   TU_RdInt    := RT_Entry (8) ;
   TU_RdChar   := RT_Entry (9) ;
   TU_RdBool   := RT_Entry (10) ;
   TU_RdLn     := RT_Entry (11) ;
   TU_Halt     := RT_Entry (12) ;
   TU_WrInl    := RT_Entry (13) ;      (* inline string literal *)
   TU_RdByte   := RT_Entry (14) ;      (* a BYTE read stores one byte *)
   TU_SetOp    := RT_Entry (31) ;
   TU_SetCmp   := RT_Entry (32) ;
   TU_SetCopy  := RT_Entry (33) ;
   TU_SetSingle := RT_Entry (67) ;
   TU_FileAssign  := RT_Entry (34) ;
   TU_FileReset   := RT_Entry (35) ;
   TU_FileRewrite := RT_Entry (36) ;
   TU_FileClose   := RT_Entry (37) ;
   TU_IoResult    := RT_Entry (38) ;
   TU_IoStore     := RT_Entry (39) ;
   TU_HeapNew     := RT_Entry (40) ;
   TU_FileEof     := RT_Entry (41) ;
   TU_FileReadln  := RT_Entry (42) ;
   TU_FileRdtok   := RT_Entry (65) ;
   TU_FileRdln    := RT_Entry (66) ;
   TU_IntFmt      := RT_Entry (43) ;
   TU_IntFmtW     := RT_Entry (62) ;
   TU_StrFmtW     := RT_Entry (63) ;
   TU_ValInt      := RT_Entry (44) ;
   TU_StrCopy     := RT_Entry (45) ;
   TU_ValReal     := RT_Entry (46) ;
   TU_RealAbs     := RT_Entry (47) ;
   TU_RealSqrt    := RT_Entry (48) ;
   TU_RealLn      := RT_Entry (49) ;
   TU_RealExp     := RT_Entry (50) ;
   TU_RealSin     := RT_Entry (51) ;
   TU_RealCos     := RT_Entry (52) ;
   TU_RealArctan  := RT_Entry (53) ;
   TU_RealIntFunc := RT_Entry (27) ;
   TU_StrDelete   := RT_Entry (54) ;
   TU_StrInsert   := RT_Entry (55) ;
   TU_WrStr    := RT_Entry (15) ;      (* a string variable is written through
                                          the address on the stack *)
   TU_RdStr    := RT_Entry (16) ;      (* readln(s)/read(s): TPSRC8 prdstr,
                                          TPSRC4 xrdstr *)
   TU_StrStore := RT_Entry (17) ;      (* s := t: TPSRC8 asnvar, TPSRC2 strstore *)
   TU_CmpStr   := RT_Entry (18) ;      (* string compare: TPSRC9 vcompare,
                                          TPSRC2 cmpstr *)
   TU_StrCat   := RT_Entry (19) ;      (* string concatenation: TPSRC2 xconcat *)
   TU_WrIntW   := RT_Entry (20) ;      (* width-aware integer: `I:2' *)
END Inittur ;

PROCEDURE HeadWord (VAR slot : CARDINAL) ;
BEGIN
   slot := pc ;
   Eword (0)
END HeadWord ;

PROCEDURE Compile (VAR errNo, errPos : CARDINAL) : BOOLEAN ;
VAR tok : CARDINAL ;
    overProc : CARDINAL ;
    hasProc : BOOLEAN ;
BEGIN
   Inittur () ;
   IF OK () THEN
      (* Resolve every {$I} first: the parser (and DeclaresProc's lookahead)
         must see one finished buffer.  See ExpandIncludes. *)
      ExpandIncludes ()
   END ;
   IF OK () THEN
      (* program prologue: header words, CALL initmem, MOV BP,SP *)
      HeadWord (hdrFlag) ;
      HeadWord (hdrCS) ;
      HeadWord (hdrDS) ;
      HeadWord (hdrHeap) ;
      HeadWord (hdrMax) ;
      Eword (16) ;                  (* max open files *)
      Eword (0) ;                   (* input buffer word *)
      Eword (0) ;                   (* output buffer word *)
      (* Here, and not one line earlier, is the first instruction of the
         program: everything above is the header, which is DATA.  The entry
         jump has to land exactly here.  Recorded rather than assumed, so that
         a header that grows a word moves the target with it. *)
      prologAt := pc ;
      (* TU_InitMem takes the header offset in AX, not on the stack, so the
         AX load has to precede the call.  Previously the prologue called
         offset 8 - which in this layout is the hdrMax word - and that was
         coherent only because the runtime was not there.  Now it is the
         real header. *)
      EmMovAxi ((rtSz + LoadBias) MOD 10000H) ;
      DropC (EmCall (TU_InitMem)) ;
      EmMovBpSp () ;
      (* [@@ATTR] := 7 - the default text attribute, before any LowVideo or
         NormVideo runs.  The data area is zero-filled, and attribute 0 would
         make every clear black-on-black.  Through EmCrtSeq, not raw Ebyte:
         Compile is not a one-line emitter, and the helper audit rightly
         refuses to let a byte-emitting statement hide inside it. *)
      EmCrtSeq (CrtLow) ;
      IF MatchKey (tok) AND (tok = TkProgram) THEN
         (* MatchKey stops right after "PROGRAM", so the optional program
            name normally follows blanks.  Skip them before testing for the
            name: otherwise Alpha sees the blank, the name is never consumed
            and IfMatchSemi reports ENoSemi at the name. *)
         Skip () ;
         IF Alpha (CurCh ()) THEN
            GetWord ()
         END ;
         IF MatchDelim ('(') THEN
            WHILE NOT MatchDelim (')') DO
               IF Alpha (CurCh ()) THEN
                  GetWord ()
               END ;
               IF CurCh () = ',' THEN
                  DropCh (GetCh ())
               END
            END
         END ;
         IfMatchSemi ()
      END ;
      IF OK () THEN
         (* Jump over the procedure bodies, if there are any.  DefPart
            compiles them HERE, between the prologue and the main statement
            part, and there was no jump - so a program with a procedure fell
            off the end of the prologue into the first procedure.  See
            DeclaresProc for why the condition is asked before DefPart runs
            and not after. *)
         hasProc := DeclaresProc () ;
         IF hasProc THEN
            overProc := EmJmpNear (0)
         END ;
         DefPart () ;
         IF OK () THEN
            (* A separate flag, NOT `overProc # 0`.  EmJmpNear returns a
               patch SLOT, and slot 0 is a perfectly ordinary slot - the
               first forward jump in a program is slot 0.  So a zero test
               cannot tell "no forward jump" from "forward jump in slot 0",
               it just skips the first patch, and the jump keeps its
               placeholder target of 0.  The program then jumped to image
               offset 0, i.e. back to the entry jump, and ran the runtime
               and the whole program again, forever.  The slot is only
               valid together with a boolean saying a slot was taken. *)
            IF hasProc THEN
               SetPatTgt (overProc, pc)
            END ;
            IF MatchKey (tok) AND (tok = TkBegin) THEN
               Compound () ;
               IF OK () THEN
                  EmXorAxAx () ;
                  DropC (EmCall (TU_ProgEnd)) ;
                  ResolvePatches () ;
                  (* Program-only sizes.  The runtime is not part of the
                     program's code, and the fixture table has always meant
                     "the program's own code", so subtract it here rather
                     than making every expectation in expected.tsv wrong. *)
                  codeSz := pc - rtSz ;
                  dataSz := dc - dataBase ;
                  (* Header words.  The layout is ours (the original's is
                     bigger and serves a real overlay loader), but
                     Runtime.EmitInitMem reads +4 and +8, so hdrDS and
                     hdrHeap must be the data base and the data end. *)
                  (* The entry jump's displacement.  A .COM is entered at
                     CS:0100 = file offset 0, so the jump is the only thing
                     that decides where execution starts, and it has to land
                     on the START of the program code - the prologue, which is
                     at rtSz - not on pc, which is the END of it.  (Patching
                     pc - EntSize, i.e. the end, lands one byte past the last
                     instruction, in the zero-filled code/data gap, where the
                     CPU slides through `ADD [BX+SI],AL' until it faults.)
                     The displacement is measured from the END of the jump,
                     and both addresses are image-absolute, so the load
                     segment cancels. *)
                  (* The entry jump's displacement.  A .COM is entered at
                     CS:0100 = file offset 0, so this jump is the only thing
                     that decides where execution starts.

                     The target is prologAt - where the prologue ACTUALLY
                     began, recorded before the header words were emitted,
                     and the header is 16 bytes long, so this is rtSz + 16 and
                     NOT rtSz.  Landing on rtSz lands on the HEADER, which is
                     data, and the CPU then decodes sixteen bytes of it as
                     instructions.  That failure is spectacularly
                     non-deterministic across programs: 01 00 is
                     `ADD [BX+SI],AX' and is harmless, so writeln('hi') ran
                     fine by sliding through the header into the prologue,
                     while t07's hdrHeap word 90 12 decodes as a LOCK-prefixed
                     ADD whose displacement crosses a page and faults, and the
                     program hung with no output at all.  Both looked like
                     "the jump is in the right area".  Recording the position
                     rather than assuming it means a future header that grows
                     a word cannot silently reintroduce this. *)
                  PatchWord (entRel, (prologAt - EntSize) MOD 10000H) ;
                  PatchWord (hdrFlag, 1) ;
                  (* Every OFFSET field in the header is a segment offset,
                     i.e. an image offset plus LoadBias - one convention for
                     the whole structure, so that nobody has to remember
                     which of these five words is numbered which way.

                       hdrFlag  1  set, so a loader can recognise the header
                       hdrCS     end of the generated code
                       hdrDS     first byte of the data area   <- read by initmem
                       hdrHeap   one past the last             <- read by initmem
                       hdrMax    0 (no overlay loader yet)

                     hdrDS and hdrHeap are the two that are CONSUMED, and
                     omitting the bias there is a silent no-op: initmem would
                     clear a range starting 0100h below the data, off the
                     front of the image, and never reach the globals at the
                     end.  Nothing crashes, and the globals keep whatever the
                     loader left in them. *)
                  PatchWord (hdrCS, pc + LoadBias) ;
                  PatchWord (hdrDS, dataBase + LoadBias) ;
                  PatchWord (hdrHeap, dc + LoadBias) ;
                  PatchWord (hdrMax, 0)
               END
            ELSE
               Err (EUnknown)
            END
         END
      END
   END ;
   IF NOT MatchDelim ('.') THEN
      Err (EPointExp)
   END ;
   IF abortFac THEN
      errNo := errNum ;         (* was "errNo := errNo": a self-assignment,
                                   because the formal shadowed the module
                                   variable, so the error code always
                                   reached the caller as 0 *)
      errPos := txerrPos ;
      RETURN FALSE
   END ;
   errNo := 0 ;
   errPos := 0 ;
   RETURN TRUE
END Compile ;

PROCEDURE CodeBytes () : CARDINAL ;
BEGIN
   RETURN codeSz
END CodeBytes ;

PROCEDURE DataBytes () : CARDINAL ;
BEGIN
   RETURN dataSz
END DataBytes ;

PROCEDURE ImageBytes () : CARDINAL ;
(* Total linked image size: rtSz (the runtime) + CodeBytes (the program).
   The data is NOT part of this image: globals live at DataBase (8000h image)
   and initmem zeroes them.  The .COM is exactly these bytes. *)
BEGIN
   RETURN rtSz + codeSz
END ImageBytes ;

PROCEDURE DataBase () : CARDINAL ;
(* image-absolute offset at which the data area begins (DataStart = 0A000H).
   The data is outside the .COM; initmem zeroes [dataBase, dataBase+dataSz)
   through the header's hdrDS/hdrHeap words. *)
BEGIN
   RETURN dataBase
END DataBase ;

PROCEDURE ImageByteAt (i : CARDINAL) : BYTE ;
(* i-th byte of the WHOLE image, runtime included, so a test can check the
   real thing a .COM would contain.  Returns 0 past the end. *)
BEGIN
   IF i >= rtSz + codeSz THEN
      RETURN 0
   END ;
   RETURN cbuf [i]
END ImageByteAt ;

PROCEDURE CodeByteAt (i : CARDINAL) : BYTE ;
(* i-th byte of the emitted image, for test harnesses that need to check
   the generated 8086 code rather than just its size.  Returns 0 past the
   end of the image. *)
BEGIN
   IF i >= codeSz THEN
      RETURN 0
   END ;
   RETURN cbuf [i]
END CodeByteAt ;

END Compiler.