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 Length, CharAt ;

FROM SYSTEM IMPORT BYTE ;

FROM Runtime IMPORT RT_Build, RT_Size, RT_Byte, RT_Entry ;
(* 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. *)

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

CONST
   MaxLine   = 128 ;
   MaxName   = 31 ;
   MaxCode   = 24000 ;
   MaxSym    = 3000 ;
   MaxPatch  = 2000 ;
   MaxPend   = 400 ;

   (* type codes (TP3 vartp) *)
   TNone    = 0 ;  TArray  = 1 ;  TRecord = 2 ;  TSet  = 3 ;
   TPtr     = 4 ;  TFile   = 5 ;  TText   = 6 ;  TUntyp = 7 ;
   TString  = 8 ;  TReal   = 9 ;  TScalar = 10 ; TBool  = 11 ;

   (* symbol kinds *)
   KLabel   = 100H ;  KConst  = 200H ;  KType   = 300H ;
   KVar     = 400H ;  KProc   = 500H ;  KFunc   = 600H ;
   KBuiltin = 700H ;         (* standard procedure, see BI_* below *)

   (* which standard procedure a KBuiltin symbol denotes *)
   BI_Write   = 0 ;  BI_WriteLn = 1 ;  BI_Read  = 2 ;
   BI_ReadLn  = 3 ;  BI_Halt    = 4 ;

   (* keyword tokens *)
   TkNone = 0 ;   TkProgram = 1 ;  TkBegin  = 2 ;  TkEnd = 3 ;
   TkIf   = 4 ;   TkThen    = 5 ;  TkElse   = 6 ;  TkWhile = 7 ;
   TkDo   = 8 ;   TkRepeat  = 9 ;  TkUntil  = 10 ; TkFor  = 11 ;
   TkTo   = 12 ;  TkDownto  = 13 ; TkCase   = 14 ; TkOf   = 15 ;
   TkGoto = 16 ;  TkExit    = 17 ; TkWith   = 18 ; TkVar  = 19 ;
   TkConst= 20 ;  TkType    = 21 ; TkLabel  = 22 ; TkProcedure = 23 ;
   TkFunction = 24 ; TkNil   = 25 ; TkAnd    = 26 ; TkOr  = 27 ;
   TkNot  = 28 ;  TkDiv     = 29 ; TkMod     = 30 ; TkIn  = 31 ;
   TkFile = 32 ;  TkText    = 33 ; TkRecord  = 34 ; TkArray = 35 ;
   TkSet  = 36 ;  TkPacked  = 37 ; TkForward = 38 ; TkExternal = 39 ;
   TkAbsolute = 40 ; TkOverlay = 41 ; TkString = 42 ;

   (* TP3 error numbers *)
   ENoSemi    = 1 ;  EPointExp  = 10 ;  ESimpType  = 30 ;
   EUnknown   = 41 ; EConstRange = 45 ; EMemOvf    = 98 ;
   ECompOvf   = 99 ; ENoLib     = 102 ; ETypeErr   = 56 ;

   AposC      = 39 ;            (* ORD ("'") - avoids quote-in-quote *)

(* ---------------------------------------------------------------- *)
(*  types                                                           *)
(* ---------------------------------------------------------------- *)

TYPE
   SymEntry =
      RECORD
         name   : ARRAY [0..MaxName] OF CHAR ;
         tag    : CARDINAL ;
         cls    : CARDINAL ;
         size   : CARDINAL ;
         elem   : CARDINAL ;
         off    : CARDINAL ;
         lval   : LONGINT ;
         level  : CARDINAL ;
         local  : BOOLEAN ;
         resvar : CARDINAL ;
         goPos  : CARDINAL ;
         defnd  : BOOLEAN ;
         fwd    : BOOLEAN ;
      END ;

   PatchRec =
      RECORD
         place  : CARDINAL ;
         target : CARDINAL ;
         filled : BOOLEAN ;
      END ;

   PendRec =
      RECORD
         kind  : CARDINAL ;         (* 0 goto, 1 call *)
         who   : CARDINAL ;
         place : CARDINAL ;         (* patch slot index *)
      END ;

   ERes =
      RECORD
         cls  : CARDINAL ;
         kind : CARDINAL ;          (* 0 const, 1 var, 2 value in AX,
                                       3 string literal (cls = TString) *)
         imm  : LONGINT ;
         idx  : CARDINAL ;
         boff : CARDINAL ;          (* constant fold-in for subscripts *)
         chr  : BOOLEAN ;           (* single-quoted literal, e.g. 'a' *)
         strx : CARDINAL ;          (* string literal: index into strPool *)
      END ;

   DirRec = RECORD  rng, chk : BOOLEAN  END ;

(* ---------------------------------------------------------------- *)
(*  state                                                           *)
(* ---------------------------------------------------------------- *)

VAR
   srcPos, srcLen : CARDINAL ;

   wrd  : ARRAY [0..MaxName] OF CHAR ;

   (* String-literal pool.

      TP3 does not put a literal in the data segment at all: it emits the
      literal *inline in the code stream* as <length byte><characters>, and
      the runtime entry "wrtinl" reads the length from the return address and
      returns to just past the last character (TPSRC4 xwrtinl, TPSRC10
      estring).  So nothing here ends up in the image as data - the pool only
      has to survive from the moment the literal is scanned until IoCall
      decides to emit it, because by then the parser has moved on. *)
   strPool : ARRAY [0..4095] OF CHAR ;
   strOff  : ARRAY [0..255] OF CARDINAL ;
   strLen  : ARRAY [0..255] OF CARDINAL ;
   strTop  : CARDINAL ;        (* next free byte in strPool *)
   strCnt  : CARDINAL ;        (* literals collected so far *)
   rdStrX  : CARDINAL ;        (* pool index of the literal RdConst just read *)

   symtab : ARRAY [0..MaxSym - 1] OF SymEntry ;
   symTop : CARDINAL ;

   patches : ARRAY [0..MaxPatch - 1] OF PatchRec ;
   nPatch  : CARDINAL ;

   pend    : ARRAY [0..MaxPend - 1] OF PendRec ;
   nPend   : CARDINAL ;

   exitPatch : ARRAY [0..63] OF CARDINAL ;
   exitCnt    : CARDINAL ;
   brkSave    : ARRAY [0..15] OF CARDINAL ;
   loopTy     : ARRAY [0..15] OF CARDINAL ;   (* 1 while/repeat, 2 for *)
   brkN       : CARDINAL ;

   caseJmp : ARRAY [0..63] OF CARDINAL ;
   caseN   : CARDINAL ;

   pc, dc  : CARDINAL ;
   varspc  : CARDINAL ;
   cbuf    : ARRAY [0..MaxCode - 1] OF BYTE ;

   codeSz, dataSz : CARDINAL ;

   (* Image layout, all image-absolute.  rtSz is where the runtime ends and
      the program header begins; dataBase is where the data area begins
      (rtSz + 1000H, a fixed 4 KiB above the code).  codeSz and dataSz are
      PROGRAM sizes - the runtime is excluded - so the numbers the fixture
      table pins keep meaning what they meant before the runtime was
      prepended. *)
   rtSz, dataBase : CARDINAL ;

   (* Runtime entry offsets inside the emitted image, i.e. offsets into the
      runtime blob, which the linker places at offset 0.  They were a
      hand-written placeholder ladder until the runtime was wired in; they are
      now taken from Runtime.RT_Entry, which derives them from where the code
      actually lands in the assembled blob.  Not a CONST block any more
      because RT_Entry is a function.

      Standard-procedure entries: TP3 does NOT pass a descriptor -
      TPSRC8 pwriteln/pwrloop inspects each argument's class in CL and emits
      a *different* call per type, so the type is fixed at compile time and
      the runtime needs only the value.  Mirrored here. *)
   TU_InitMem  : CARDINAL ;
   TU_ProgEnd  : CARDINAL ;
   TU_StackChk : CARDINAL ;
   TU_WrInt    : CARDINAL ;  TU_WrChar : CARDINAL ;  TU_WrBool : CARDINAL ;
   TU_WrReal   : CARDINAL ;  TU_WrLn   : CARDINAL ;
   TU_RdInt    : CARDINAL ;  TU_RdChar : CARDINAL ;  TU_RdBool : CARDINAL ;
   TU_RdLn     : CARDINAL ;  TU_Halt   : CARDINAL ;
   TU_WrInl    : CARDINAL ;  (* inline string literal; NO stack argument *)

   abortFac : BOOLEAN ;
   errNum   : CARDINAL ;        (* NOT "errNo": Compile's formal of that
                                  name would shadow it, and the caller's
                                  errNo would never be filled in *)
   txerrPos : CARDINAL ;

   lexnest  : CARDINAL ;
   curIsFunc : BOOLEAN ;
   resultVar : CARDINAL ;

   locFree  : CARDINAL ;       (* next local slot (BP-relative, 8-bit) *)
   locBytes : CARDINAL ;       (* frame size for SUB SP *)
   parmOff  : CARDINAL ;       (* next parameter slot (BP-relative) *)

   dirs     : DirRec ;

   tmpA, tmpB : CARDINAL ;     (* global scratch word addresses *)

   hdrFlag, hdrCS, hdrDS, hdrHeap, hdrMax : CARDINAL ;

   kName : ARRAY [0..42] OF ARRAY [0..15] OF CHAR ;
   kTk   : ARRAY [0..42] OF CARDINAL ;

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

PROCEDURE CurCh () : CHAR ;
BEGIN
   IF srcPos >= srcLen THEN
      RETURN 0C
   END ;
   RETURN CharAt (srcPos)
END CurCh ;

PROCEDURE GetCh () : CHAR ;
VAR ch : CHAR ;
BEGIN
   ch := CurCh () ;
   IF srcPos < srcLen THEN
      INC (srcPos)
   END ;
   RETURN ch
END GetCh ;

PROCEDURE PeekAhead (k : CARDINAL) : CHAR ;
BEGIN
   IF srcPos + k >= srcLen THEN
      RETURN 0C
   END ;
   RETURN CharAt (srcPos + k)
END PeekAhead ;

PROCEDURE Digit (ch : CHAR) : BOOLEAN ;
BEGIN
   RETURN (ch >= '0') AND (ch <= '9')
END Digit ;

PROCEDURE Alpha (ch : CHAR) : BOOLEAN ;
BEGIN
   RETURN ((ch >= 'A') AND (ch <= 'Z')) OR ((ch >= 'a') AND (ch <= 'z'))
          OR (ch = '_')
END Alpha ;

PROCEDURE AlphaNum (ch : CHAR) : BOOLEAN ;
BEGIN
   RETURN (Alpha (ch)) OR (Digit (ch))
END AlphaNum ;

PROCEDURE IsHexCh (ch : CHAR) : BOOLEAN ;
BEGIN
   RETURN (Digit (ch)) OR ((ch >= 'A') AND (ch <= 'F'))
          OR ((ch >= 'a') AND (ch <= 'f'))
END IsHexCh ;

PROCEDURE Upper (ch : CHAR) : CHAR ;
BEGIN
   IF (ch >= 'a') AND (ch <= 'z') THEN
      RETURN CHR (ORD (ch) - ORD ('a') + ORD ('A'))
   END ;
   RETURN ch
END Upper ;

PROCEDURE W16 (x : LONGINT) : CARDINAL ;
(* fold x modulo 10000H, handling negatives (no negative MOD) *)
VAR m : CARDINAL ;
BEGIN
   IF x >= 0 THEN
      RETURN VAL (CARDINAL, x MOD 10000H)
   END ;
   m := VAL (CARDINAL, (0 - x) MOD 10000H) ;
   RETURN (10000H - m) MOD 10000H
END W16 ;

PROCEDURE DropCh (v : CHAR) ;
BEGIN
END DropCh ;

PROCEDURE DropB (v : BOOLEAN) ;
BEGIN
END DropB ;

PROCEDURE DropC (v : CARDINAL) ;
BEGIN
END DropC ;

PROCEDURE BitAnd (a, b : LONGINT) : LONGINT ;
BEGIN
   RETURN VAL (LONGINT, CARDINAL (VAL (BITSET, W16 (a))
                                 * VAL (BITSET, W16 (b))))
END BitAnd ;

PROCEDURE BitOr (a, b : LONGINT) : LONGINT ;
BEGIN
   RETURN VAL (LONGINT, CARDINAL (VAL (BITSET, W16 (a))
                                 + VAL (BITSET, W16 (b))))
END BitOr ;

PROCEDURE BitNot (a : LONGINT) : LONGINT ;
BEGIN
   RETURN VAL (LONGINT, CARDINAL (VAL (BITSET, 0FFFFH)
                                 - VAL (BITSET, W16 (a))))
END BitNot ;

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

PROCEDURE Err (n : CARDINAL) ;
BEGIN
   IF NOT abortFac THEN
      abortFac := TRUE ;
      errNum := n ;
      txerrPos := srcPos
   END
END Err ;

PROCEDURE OK () : BOOLEAN ;
BEGIN
   RETURN NOT abortFac
END OK ;

(* ---------------------------------------------------------------- *)
(*  emission :  ebyte / eword / ecall / ejump                        *)
(* ---------------------------------------------------------------- *)

PROCEDURE Ebyte (b : BYTE) ;
BEGIN
   IF pc >= MaxCode THEN
      Err (EMemOvf)
   ELSE
      cbuf [pc] := b ;
      INC (pc)
   END
END Ebyte ;

PROCEDURE Eword (w : CARDINAL) ;
BEGIN
   Ebyte (VAL (BYTE, w MOD 100H)) ;
   Ebyte (VAL (BYTE, (w DIV 100H) MOD 100H))
END Eword ;

PROCEDURE PatchWord (at, w : CARDINAL) ;
(* Store a 16-bit word into cbuf at an absolute offset.

   A helper, because writing this inline got it wrong in all four header
   words: the low byte was (w DIV 16) MOD 100H, which is a NIBBLE shift, not
   the byte shift (w MOD 100H).  So 1181h - the data base - was stored as
   0118h = 280.  It was invisible for as long as nothing read those words,
   which is exactly what "write it inline once and trust it" buys you. *)
BEGIN
   cbuf [at] := VAL (BYTE, w MOD 100H) ;
   cbuf [at + 1] := VAL (BYTE, (w DIV 100H) MOD 100H)
END PatchWord ;

PROCEDURE AddPatch (place, target : CARDINAL) ;
BEGIN
   IF nPatch < MaxPatch THEN
      patches [nPatch].place := place ;
      patches [nPatch].target := target ;
      patches [nPatch].filled := FALSE ;
      INC (nPatch)
   ELSE
      Err (ECompOvf)
   END
END AddPatch ;

PROCEDURE SetPatTgt (idx, t : CARDINAL) ;
BEGIN
   IF idx < nPatch THEN
      patches [idx].target := t
   END
END SetPatTgt ;

PROCEDURE EmCall (target : CARDINAL) : CARDINAL ;
(* E8 rel16 near call; target = 0 => forward (patched later).
   Returns the patch slot, or 0 when resolved directly. *)
VAR rel, p : CARDINAL ;
BEGIN
   Ebyte (0E8H) ;
   IF target = 0 THEN
      Eword (0) ;
      p := nPatch ;
      AddPatch (pc - 2, 0) ;
      RETURN p
   END ;
   (* rel16 is measured from the END of the instruction.  Here pc already
      points past the opcode(s) and at the displacement field, so the
      instruction ends at pc+2 - the same convention ResolvePatches uses
      with "place + 2".  Omitting the +2 lands every direct call/jump 2 bytes
      past its target. *)
   rel := (target + 10000H - (pc + 2)) MOD 10000H ;
   Eword (rel) ;
   RETURN 0
END EmCall ;

PROCEDURE EmJmpNear (target : CARDINAL) : CARDINAL ;
(* E9 rel16; target = 0 => forward. Returns patch slot or 0. *)
VAR rel, p : CARDINAL ;
BEGIN
   Ebyte (0E9H) ;
   IF target = 0 THEN
      Eword (0) ;
      p := nPatch ;
      AddPatch (pc - 2, 0) ;
      RETURN p
   END ;
   rel := (target + 10000H - (pc + 2)) MOD 10000H ;   (* see EmCall *)
   Eword (rel) ;
   RETURN 0
END EmJmpNear ;

PROCEDURE EmJcc (cc : BYTE ; target : CARDINAL) : CARDINAL ;
(* 0F 8x rel16 near conditional; target = 0 => forward. *)
VAR rel, p : CARDINAL ;
BEGIN
   Ebyte (0FH) ;
   Ebyte (cc) ;
   IF target = 0 THEN
      Eword (0) ;
      p := nPatch ;
      AddPatch (pc - 2, 0) ;
      RETURN p
   END ;
   rel := (target + 10000H - (pc + 2)) MOD 10000H ;   (* see EmCall *)
   Eword (rel) ;
   RETURN 0
END EmJcc ;

PROCEDURE ResolvePatches () ;
VAR i : CARDINAL ;
    rel : CARDINAL ;
BEGIN
   i := 0 ;
   WHILE i < nPatch DO
      IF NOT patches [i].filled THEN
         rel := (patches [i].target + 10000H - (patches [i].place + 2))
                MOD 10000H ;
         cbuf [patches [i].place] := VAL (BYTE, rel MOD 100H) ;
         cbuf [patches [i].place + 1] := VAL (BYTE, (rel DIV 100H) MOD 100H) ;
         patches [i].filled := TRUE
      END ;
      INC (i)
   END
END ResolvePatches ;

(* 1-byte const emitters *)

PROCEDURE EmMovAxi (imm : CARDINAL) ;
BEGIN
   Ebyte (0B8H) ; Eword (imm)
END EmMovAxi ;

PROCEDURE EmMovBpSp () ;
BEGIN
   Ebyte (8BH) ; Ebyte (0ECH)
END EmMovBpSp ;

PROCEDURE EmMovAh0 () ;
BEGIN
   Ebyte (0B4H) ; Ebyte (0H)
END EmMovAh0 ;

PROCEDURE EmMovAxSp () ;
(* MOV AX,[SP].  Needs a SIB byte, and [SP] cannot be encoded with mod=00
   (that would compute BP+SP), so it is mod=01 / SIB=24h / disp8=0.  Emitting
   just "8B 04" left the SIB slot unfilled, which silently ate the *next*
   instruction - the case-label CMP - and turned every case comparison into
   a load from a garbage address. *)
BEGIN
   Ebyte (8BH) ; Ebyte (44H) ; Ebyte (24H) ; Ebyte (0)
END EmMovAxSp ;

PROCEDURE EmMovCxSp () ;
BEGIN
   Ebyte (8BH) ; Ebyte (0CH)
END EmMovCxSp ;

PROCEDURE EmPushAx () ;
BEGIN
   Ebyte (50H)
END EmPushAx ;

PROCEDURE EmPopCx () ;
BEGIN
   Ebyte (59H)
END EmPopCx ;

PROCEDURE EmPopDx () ;
BEGIN
   Ebyte (5AH)
END EmPopDx ;

PROCEDURE EmXchgAxCx () ;
BEGIN
   Ebyte (93H)
END EmXchgAxCx ;

PROCEDURE EmXorAxAx () ;
BEGIN
   Ebyte (33H) ; Ebyte (0C0H)
END EmXorAxAx ;

PROCEDURE EmAddAxCx () ;
BEGIN
   Ebyte (3H) ; Ebyte (0C1H)
END EmAddAxCx ;

PROCEDURE EmSubAxCx () ;
BEGIN
   Ebyte (2BH) ; Ebyte (0C1H)
END EmSubAxCx ;

PROCEDURE EmMulAxCx () ;
BEGIN
   Ebyte (0F7H) ; Ebyte (0E9H)
END EmMulAxCx ;

PROCEDURE EmIDivAxCx () ;
BEGIN
   Ebyte (99H) ; Ebyte (0F7H) ; Ebyte (0F9H)
END EmIDivAxCx ;

PROCEDURE EmAndAxCx () ;
BEGIN
   Ebyte (23H) ; Ebyte (0C1H)
END EmAndAxCx ;

PROCEDURE EmOrAxCx () ;
BEGIN
   Ebyte (0BH) ; Ebyte (0C1H)
END EmOrAxCx ;

PROCEDURE EmNegAx () ;
BEGIN
   Ebyte (0F7H) ; Ebyte (0D8H)
END EmNegAx ;

PROCEDURE EmNotAx () ;
BEGIN
   Ebyte (0F7H) ; Ebyte (0D0H)
END EmNotAx ;

PROCEDURE EmCmpAxCx () ;
BEGIN
   Ebyte (3BH) ; Ebyte (0C1H)
END EmCmpAxCx ;

PROCEDURE EmCmpAxi (imm : CARDINAL) ;
BEGIN
   Ebyte (03DH) ; Eword (imm)
END EmCmpAxi ;

PROCEDURE EmSetcc (cc : BYTE) ;
BEGIN
   Ebyte (0FH) ; Ebyte (cc) ; Ebyte (0C0H) ;
   EmMovAh0 ()
END EmSetcc ;

PROCEDURE EmIncAx () ;
BEGIN
   Ebyte (40H)
END EmIncAx ;

PROCEDURE EmDecAx () ;
BEGIN
   Ebyte (48H)
END EmDecAx ;

PROCEDURE EmBpDisp (off : CARDINAL) ;
(* Emit the ModR/M byte and displacement for a [BP+off] operand, picking the
   encoding from the size of off.  This is the ONE place that choice is made,
   because getting it wrong is invisible: 8B 46 d8 and 8B 86 lo hi are both
   well-formed MOVs, both decode cleanly, and only one of them reads the
   variable the symbol table names.  So the two are chosen here, once, rather
   than re-derived at each of the four call sites.  See the ModR/M table in
   Runtime.mod.

      off <= 127 -> mod=01 rm=110 -> 46 <disp8>      3 bytes with the opcode
      otherwise  -> mod=10 rm=110 -> 86 <disp16>     4 bytes with the opcode

   Both displacements are SIGNED, and that is the whole subtlety:

     - `off` is a 16-bit value and locals are allocated DOWNWARD from
       0FFFEh (locFree starts there and is decremented per declaration), so
       the first local of a procedure sits at off = 0FFFC, which is -4.  The
       disp16 form reads those same two bytes as a signed value and addresses
       [BP-4] correctly.  There is no overflow case: all 65536 values of `off`
       are representable, and a frame larger than 64K is a different problem.
     - The old code took `off MOD 100H` and always emitted disp8.  That is
       the correct low byte for every displacement, so it was accidentally
       right across -32768..+127, which is where locals actually live.  It
       went wrong at +128, where disp8 80h is -128 and not +128.  So this
       changes no existing program's bytes and fixes the one case that was
       broken -- a bug nobody had hit yet, which is exactly why it wanted a
       test rather than an argument. *)
BEGIN
   IF off <= 127 THEN
      Ebyte (46H) ; Ebyte (VAL (BYTE, off))
   ELSE
      Ebyte (86H) ; Eword (off)
   END
END EmBpDisp ;

PROCEDURE EmLoadVar (local : BOOLEAN ; off, nbytes : CARDINAL) ;
BEGIN
   IF nbytes = 1 THEN
      IF local THEN
         Ebyte (8AH) ; EmBpDisp (off)
      ELSE
         Ebyte (0A0H) ; Eword (off)
      END
   ELSE
      IF local THEN
         Ebyte (8BH) ; EmBpDisp (off)
      ELSE
         Ebyte (0A1H) ; Eword (off)
      END
   END
END EmLoadVar ;

PROCEDURE EmStoreVar (local : BOOLEAN ; off, nbytes : CARDINAL) ;
BEGIN
   IF nbytes = 1 THEN
      IF local THEN
         Ebyte (88H) ; EmBpDisp (off)
      ELSE
         Ebyte (0A2H) ; Eword (off)
      END
   ELSE
      IF local THEN
         Ebyte (89H) ; EmBpDisp (off)
      ELSE
         Ebyte (0A3H) ; Eword (off)
      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. *)
BEGIN
   IF local THEN
      Ebyte (8DH) ; EmBpDisp (off)
   ELSE
      Ebyte (8DH) ; Ebyte (06H) ; Eword (off)
   END ;
   EmPushAx ()
END EmPushVarAddr ;

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                                                    *)
(* ---------------------------------------------------------------- *)

PROCEDURE NameEq (a : ARRAY OF CHAR ; b : ARRAY OF CHAR) : BOOLEAN ;
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   LOOP
      IF i > HIGH (a) THEN
         RETURN FALSE
      END ;
      IF i > HIGH (b) THEN
         RETURN FALSE
      END ;
      IF a [i] # b [i] THEN
         RETURN FALSE
      END ;
      IF a [i] = 0C THEN
         RETURN TRUE
      END ;
      INC (i)
   END
END NameEq ;

PROCEDURE CopyStr (VAR dst : ARRAY OF CHAR ; src : ARRAY OF CHAR) ;
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   LOOP
      IF i > HIGH (dst) THEN
         dst [HIGH (dst)] := 0C ;
         RETURN
      END ;
      IF i > HIGH (src) THEN
         dst [i] := 0C ;
         RETURN
      END ;
      dst [i] := src [i] ;
      IF src [i] = 0C THEN
         RETURN
      END ;
      INC (i)
   END
END CopyStr ;

PROCEDURE CopyWord (name : ARRAY OF CHAR) ;
(* stash current word into global wrd (uppercased) *)
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   LOOP
      IF i > HIGH (name) THEN
         wrd [i] := 0C ;
         RETURN
      END ;
      IF i > MaxName THEN
         wrd [MaxName] := 0C ;
         RETURN
      END ;
      IF name [i] = 0C THEN
         wrd [i] := 0C ;
         RETURN
      END ;
      wrd [i] := Upper (name [i]) ;
      INC (i)
   END
END CopyWord ;

PROCEDURE SaveWord (VAR dst : ARRAY OF CHAR) ;
(* copy wrd into dst *)
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   LOOP
      IF i > HIGH (dst) THEN
         dst [HIGH (dst)] := 0C ;
         RETURN
      END ;
      IF i > MaxName THEN
         dst [MaxName] := 0C ;
         RETURN
      END ;
      dst [i] := wrd [i] ;
      IF wrd [i] = 0C THEN
         RETURN
      END ;
      INC (i)
   END
END SaveWord ;

PROCEDURE NumToName (n : CARDINAL ; VAR dst : ARRAY OF CHAR) ;
VAR buf : ARRAY [0..9] OF CHAR ;
    i, j : CARDINAL ;
BEGIN
   IF n = 0 THEN
      dst [0] := '0' ;
      dst [1] := 0C ;
      RETURN
   END ;
   i := 0 ;
   WHILE n > 0 DO
      IF i <= 9 THEN
         buf [i] := CHR (ORD ('0') + (n MOD 10)) ;
         INC (i)
      END ;
      n := n DIV 10
   END ;
   j := 0 ;
   WHILE i > 0 DO
      DEC (i) ;
      IF j <= HIGH (dst) THEN
         dst [j] := buf [i] ;
         INC (j)
      END
   END ;
   IF j <= HIGH (dst) THEN
      dst [j] := 0C
   END
END NumToName ;

PROCEDURE NewSym (name : ARRAY OF CHAR ; tag : CARDINAL ;
                  cls, size, elem, off : CARDINAL ; v : LONGINT ;
                  local : BOOLEAN) : CARDINAL ;
VAR e : SymEntry ;
BEGIN
   IF symTop >= MaxSym THEN
      Err (ECompOvf) ;
      RETURN 0
   END ;
   CopyWord (name) ;
   CopyStr (e.name, wrd) ;
   e.tag := tag ;
   e.cls := cls ;
   e.size := size ;
   e.elem := elem ;
   e.off := off ;
   e.lval := v ;
   e.level := lexnest ;
   e.local := local ;
   e.resvar := 0 ;
   e.goPos := 0 ;
   e.defnd := FALSE ;
   e.fwd := FALSE ;
   symtab [symTop] := e ;
   INC (symTop) ;
   RETURN symTop - 1
END NewSym ;

PROCEDURE Search (nm : ARRAY OF CHAR ; VAR idx : CARDINAL) : BOOLEAN ;
(* find nm among symbols visible at the current lexical level *)
VAR p : CARDINAL ;
BEGIN
   CopyWord (nm) ;
   p := symTop ;
   WHILE p > 0 DO
      DEC (p) ;
      IF symtab [p].level <= lexnest THEN
         IF NameEq (symtab [p].name, wrd) THEN
            idx := p ;
            RETURN TRUE
         END
      END
   END ;
   RETURN FALSE
END Search ;

PROCEDURE DupTest (nm : ARRAY OF CHAR) ;
VAR i : CARDINAL ;
BEGIN
   IF Search (nm, i) THEN
      Err (EUnknown)
   END
END DupTest ;

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

PROCEDURE InitKeys () ;
VAR i : CARDINAL ;
BEGIN
   FOR i := 0 TO 42 DO
      kTk [i] := 0 ;
      kName [i] [0] := 0C
   END ;
   kName [1] := "PROGRAM"     ; kTk [1] := TkProgram ;
   kName [2] := "BEGIN"       ; kTk [2] := TkBegin ;
   kName [3] := "END"         ; kTk [3] := TkEnd ;
   kName [4] := "IF"          ; kTk [4] := TkIf ;
   kName [5] := "THEN"        ; kTk [5] := TkThen ;
   kName [6] := "ELSE"        ; kTk [6] := TkElse ;
   kName [7] := "WHILE"       ; kTk [7] := TkWhile ;
   kName [8] := "DO"          ; kTk [8] := TkDo ;
   kName [9] := "REPEAT"      ; kTk [9] := TkRepeat ;
   kName [10] := "UNTIL"      ; kTk [10] := TkUntil ;
   kName [11] := "FOR"        ; kTk [11] := TkFor ;
   kName [12] := "TO"         ; kTk [12] := TkTo ;
   kName [13] := "DOWNTO"     ; kTk [13] := TkDownto ;
   kName [14] := "CASE"       ; kTk [14] := TkCase ;
   kName [15] := "OF"         ; kTk [15] := TkOf ;
   kName [16] := "GOTO"       ; kTk [16] := TkGoto ;
   kName [17] := "EXIT"       ; kTk [17] := TkExit ;
   kName [18] := "WITH"       ; kTk [18] := TkWith ;
   kName [19] := "VAR"        ; kTk [19] := TkVar ;
   kName [20] := "CONST"      ; kTk [20] := TkConst ;
   kName [21] := "TYPE"       ; kTk [21] := TkType ;
   kName [22] := "LABEL"      ; kTk [22] := TkLabel ;
   kName [23] := "PROCEDURE"  ; kTk [23] := TkProcedure ;
   kName [24] := "FUNCTION"   ; kTk [24] := TkFunction ;
   kName [25] := "NIL"        ; kTk [25] := TkNil ;
   kName [26] := "AND"        ; kTk [26] := TkAnd ;
   kName [27] := "OR"         ; kTk [27] := TkOr ;
   kName [28] := "NOT"        ; kTk [28] := TkNot ;
   kName [29] := "DIV"        ; kTk [29] := TkDiv ;
   kName [30] := "MOD"        ; kTk [30] := TkMod ;
   kName [31] := "IN"         ; kTk [31] := TkIn ;
   kName [32] := "FILE"       ; kTk [32] := TkFile ;
   kName [33] := "TEXT"       ; kTk [33] := TkText ;
   kName [34] := "RECORD"     ; kTk [34] := TkRecord ;
   kName [35] := "ARRAY"      ; kTk [35] := TkArray ;
   kName [36] := "SET"        ; kTk [36] := TkSet ;
   kName [37] := "PACKED"     ; kTk [37] := TkPacked ;
   kName [38] := "FORWARD"    ; kTk [38] := TkForward ;
   kName [39] := "EXTERNAL"   ; kTk [39] := TkExternal ;
   kName [40] := "ABSOLUTE"   ; kTk [40] := TkAbsolute ;
   kName [41] := "OVERLAY"    ; kTk [41] := TkOverlay ;
   kName [42] := "STRING"     ; kTk [42] := TkString
END InitKeys ;

PROCEDURE IsBlank (ch : CHAR) : BOOLEAN ;
BEGIN
   RETURN (ch = ' ') OR (ORD (ch) = 09H) OR (ORD (ch) = 0DH) OR (ORD (ch) = 0AH) OR (ORD (ch) = 0CH)
END IsBlank ;

PROCEDURE Skip () ;
(* blanks, comments { } and (* *), compiler directives {$ } / (*$ *)
   letter + sign toggles rng/chk *)
VAR ch : CHAR ;
    letter : CHAR ;
BEGIN
   WHILE NOT abortFac DO
      WHILE IsBlank (CurCh ()) DO
         ch := GetCh ()
      END ;
      IF CurCh () = '{' THEN
         ch := GetCh () ;
         IF CurCh () = '$' THEN
            ch := GetCh () ;
            letter := GetCh () ;
            ch := GetCh () ;
            IF ch = '+' THEN
               IF letter = 'R' THEN dirs.rng := TRUE END ;
               IF letter = 'I' THEN dirs.chk := TRUE END
            ELSIF ch = '-' THEN
               IF letter = 'R' THEN dirs.rng := FALSE END ;
               IF letter = 'I' THEN dirs.chk := FALSE END
            END
         END ;
         WHILE (CurCh () # '}') AND (CurCh () # 0C) DO
            ch := GetCh ()
         END ;
         IF CurCh () = '}' THEN
            ch := GetCh ()
         END
      ELSIF (CurCh () = '(') AND (PeekAhead (1) = '*') THEN
         ch := GetCh () ;
         ch := GetCh () ;
         IF CurCh () = '$' THEN
            ch := GetCh () ;
            letter := GetCh () ;
            ch := GetCh () ;
            IF ch = '+' THEN
               IF letter = 'R' THEN dirs.rng := TRUE END
            ELSIF ch = '-' THEN
               IF letter = 'R' THEN dirs.rng := FALSE END
            END
         END ;
         LOOP
            IF (CurCh () = '*') AND (PeekAhead (1) = ')') THEN
               ch := GetCh () ;
               ch := GetCh () ;
               EXIT
            END ;
            IF CurCh () = 0C THEN
               EXIT
            END ;
            ch := GetCh ()
         END
      ELSE
         RETURN
      END
   END
END Skip ;

PROCEDURE GetWord () ;
(* read identifier into wrd (uppercased); next char must be alpha *)
VAR i : CARDINAL ;
    ch : CHAR ;
BEGIN
   i := 0 ;
   ch := GetCh () ;
   LOOP
      IF i > MaxName THEN
         wrd [MaxName] := 0C ;
         RETURN
      END ;
      wrd [i] := Upper (ch) ;
      INC (i) ;
      ch := CurCh () ;
      IF NOT AlphaNum (ch) THEN
         wrd [i] := 0C ;
         RETURN
      END ;
      ch := GetCh ()
   END
END GetWord ;

PROCEDURE WddTok () : CARDINAL ;
(* map wrd -> keyword token *)
VAR i : CARDINAL ;
BEGIN
   i := 1 ;
   WHILE i <= 42 DO
      IF kName [i] [0] # 0C THEN
         IF NameEq (wrd, kName [i]) THEN
            RETURN kTk [i]
         END
      END ;
      INC (i)
   END ;
   RETURN TkNone
END WddTok ;

PROCEDURE KwAhead (word : ARRAY OF CHAR) : BOOLEAN ;
(* does the next token (past blanks/comments) equal the keyword 'word',
   without consuming it?  srcPos is saved and restored. *)
VAR save : CARDINAL ;
    k : BOOLEAN ;
BEGIN
   save := srcPos ;
   Skip () ;
   k := FALSE ;
   IF Alpha (CurCh ()) THEN
      GetWord () ;
      k := NameEq (wrd, word)
   END ;
   srcPos := save ;
   RETURN k
END KwAhead ;

PROCEDURE PeekKw (VAR tok : CARDINAL) ;
(* peek at the next keyword token without consuming it *)
VAR i : CARDINAL ;
BEGIN
   tok := TkNone ;
   i := 1 ;
   WHILE i <= 42 DO
      IF kName [i] [0] # 0C THEN
         IF KwAhead (kName [i]) THEN
            tok := kTk [i] ;
            RETURN
         END
      END ;
      INC (i)
   END
END PeekKw ;

PROCEDURE MatchKey (VAR tok : CARDINAL) : BOOLEAN ;
(* skip; if next symbol is a word, read it into wrd and set its token.
   Returns TRUE when a word was read (tok = TkNone for plain ids). *)
BEGIN
   tok := TkNone ;
   Skip () ;
   IF NOT Alpha (CurCh ()) THEN
      RETURN FALSE
   END ;
   GetWord () ;
   tok := WddTok () ;
   RETURN TRUE
END MatchKey ;

PROCEDURE MatchDelim (ch : CHAR) : BOOLEAN ;
BEGIN
   Skip () ;
   IF CurCh () = ch THEN
      DropCh (GetCh ()) ;
      RETURN TRUE
   END ;
   RETURN FALSE
END MatchDelim ;

PROCEDURE MatchAssign () : BOOLEAN ;
BEGIN
   Skip () ;
   IF (CurCh () = ':') AND (PeekAhead (1) = '=') THEN
      DropCh (GetCh ()) ;
      DropCh (GetCh ()) ;
      RETURN TRUE
   END ;
   RETURN FALSE
END MatchAssign ;

PROCEDURE MatchRange () : BOOLEAN ;
BEGIN
   Skip () ;
   IF (CurCh () = '.') AND (PeekAhead (1) = '.') THEN
      DropCh (GetCh ()) ;
      DropCh (GetCh ()) ;
      RETURN TRUE
   END ;
   RETURN FALSE
END MatchRange ;

PROCEDURE ExpectDelim (ch : CHAR ; n : CARDINAL) ;
BEGIN
   Skip () ;
   IF CurCh () = ch THEN
      DropCh (GetCh ())
   ELSE
      Err (n)
   END
END ExpectDelim ;

PROCEDURE HexVal (ch : CHAR) : CARDINAL ;
BEGIN
   IF (ch >= '0') AND (ch <= '9') THEN
      RETURN ORD (ch) - ORD ('0')
   ELSIF (ch >= 'A') AND (ch <= 'F') THEN
      RETURN ORD (ch) - ORD ('A') + 10
   END ;
   RETURN ORD (ch) - ORD ('a') + 10
END HexVal ;

PROCEDURE RdIntConst (VAR v : LONGINT) ;
(* bare integer constant; current char is digit or '$' *)
VAR acc : LONGINT ;
BEGIN
   acc := 0 ;
   IF CurCh () = '$' THEN
      DropCh (GetCh ()) ;
      WHILE IsHexCh (CurCh ()) DO
         acc := acc * 16 + VAL (LONGINT, HexVal (CurCh ())) ;
         DropCh (GetCh ())
      END
   ELSE
      WHILE Digit (CurCh ()) DO
         acc := acc * 10 + VAL (LONGINT, ORD (CurCh ()) - ORD ('0')) ;
         DropCh (GetCh ())
      END
   END ;
   v := acc
END RdIntConst ;

PROCEDURE StrNew (first : CARDINAL ; hasFirst : BOOLEAN ) : CARDINAL ;
(* Open a pool slot for a string literal, optionally pre-seeded with its
   first character.

   RdConst has to read the first character before it can tell a one-character
   literal from a longer one - the "is the next character another quote?"
   test only makes sense once something has been read - so the seeding has to
   happen here and has to advance strTop.  Leaving strTop alone and letting the
   caller write the character by hand is a trap: strTop is the next FREE byte,
   so the first StrPut lands on top of the seeded character and overwrites it.
   (That bug shipped the literal 'hi' as 69 00 - 'i' then NUL.) *)
VAR x : CARDINAL ;
BEGIN
   IF strCnt > HIGH (strOff) THEN
      Err (ECompOvf) ;                     (* too many literals in one unit *)
      RETURN 0
   END ;
   x := strCnt ;
   strOff [x] := strTop ;
   strLen [x] := 0 ;
   INC (strCnt) ;
   IF hasFirst THEN
      strPool [strTop] := CHR (first) ;
      INC (strTop) ;
      strLen [x] := 1
   END ;
   rdStrX := x ;
   RETURN x
END StrNew ;

PROCEDURE StrPut (x : CARDINAL ) ;
(* append the current source character to pool slot x *)
BEGIN
   IF x > HIGH (strOff) THEN
      RETURN
   END ;
   IF strTop > HIGH (strPool) THEN
      Err (ECompOvf) ;                     (* literal longer than the pool *)
      RETURN
   END ;
   strPool [strTop] := CurCh () ;
   INC (strTop) ;
   INC (strLen [x])
END StrPut ;

PROCEDURE RdConst (VAR v : LONGINT ; VAR cls : CARDINAL ;
                   VAR isStr : BOOLEAN) ;
(* scalar or string constant.  A string literal's text is collected into the
   pool and its slot index left in rdStrX; a single-character literal stays a
   TScalar holding its character code, which is what "c := 'a'" wants. *)
CONST q = AposC ;
BEGIN
   isStr := FALSE ;
   cls := TScalar ;
   v := 0 ;
   Skip () ;
   IF CurCh () = '$' THEN
      RdIntConst (v) ;
      cls := TScalar
   ELSIF Digit (CurCh ()) THEN
      RdIntConst (v) ;
      IF (CurCh () = '.') AND (Digit (PeekAhead (1))) THEN
         cls := TReal ;
         DropCh (GetCh ())
      END ;
      IF (CurCh () = 'E') OR (CurCh () = 'e') THEN
         cls := TReal ;
         DropCh (GetCh ())
      END ;
      IF cls = TReal THEN
         WHILE AlphaNum (CurCh ()) OR (CurCh () = '.') OR (CurCh () = '-')
               OR (CurCh () = '+') DO
            DropCh (GetCh ())
         END
      END
   ELSIF ORD (CurCh ()) = q THEN
      DropCh (GetCh ()) ;
      IF ORD (CurCh ()) = q THEN
         (* '' - the empty string.  It used to be reported as the scalar 39,
            so writeln('') printed a single quote mark.  It is a string of
            length zero, and an inline zero-length literal is exactly what the
            runtime's JCXZ path is for. *)
         DropCh (GetCh ()) ;
         isStr := TRUE ;
         cls := TString ;
         v := 0 ;
         rdStrX := StrNew (0, FALSE)
      ELSIF (CurCh () = 0C) OR ((ORD (CurCh ()) = 0DH)) OR ((ORD (CurCh ()) = 0AH)) THEN
         Err (EUnknown)
      ELSE
         v := VAL (LONGINT, ORD (GetCh ())) ;
         cls := TScalar ;
         IF ORD (CurCh ()) = q THEN
            DropCh (GetCh ())
         ELSE
            isStr := TRUE ;
            cls := TString ;
            (* Scan to the closing quote.  NB: the loop condition must test
               the CURRENT character and only the current character.  The
               obvious-looking "while CurCh # quote" with a
               "if PeekAhead(1) = quote then consume two" body is wrong:
               consuming the quote moves the cursor past it, so the next
               condition test sees the character AFTER the literal, is
               satisfied, and the scan runs on to end-of-buffer - which
               silently eats the rest of the program and makes every later
               error point at end-of-file.  Stop on the quote itself, and
               treat a doubled quote as one embedded quote character.

               The first character is already gone - it was read into v above -
               so the pool slot is pre-seeded with it. *)
            rdStrX := StrNew (VAL (CARDINAL, v), TRUE) ;
            LOOP
               IF ORD (CurCh ()) = q THEN
                  IF ORD (PeekAhead (1)) = q THEN
                     StrPut (rdStrX) ;                  (* '' inside *)
                     DropCh (GetCh ()) ; DropCh (GetCh ())
                  ELSE
                     EXIT                                (* closing quote *)
                  END
               ELSIF (CurCh () = 0C) OR (ORD (CurCh ()) = 0DH) THEN
                  Err (EUnknown) ;                         (* unterminated *)
                  EXIT
               ELSE
                  StrPut (rdStrX) ;
                  DropCh (GetCh ())
               END
            END ;
            IF ORD (CurCh ()) = q THEN
               DropCh (GetCh ())
            END
         END
      END
   ELSE
      Err (EUnknown)
   END
END RdConst ;

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

PROCEDURE ParseExpr (VAR r : ERes) ; FORWARD ;
PROCEDURE ParseAdd (VAR r : ERes) ; FORWARD ;
PROCEDURE ParseMul (VAR r : ERes) ; FORWARD ;
PROCEDURE ParseNeg (VAR r : ERes) ; FORWARD ;
PROCEDURE ParseAtom (VAR r : ERes) ; FORWARD ;
PROCEDURE ParseType (VAR cls, size, elem : CARDINAL) ; FORWARD ;
PROCEDURE Statmnt () ; FORWARD ;
PROCEDURE ParseCall (idx : CARDINAL) ; FORWARD ;
PROCEDURE ParseCallArgs (idx : CARDINAL) ; FORWARD ;
PROCEDURE EmCallMost (idx, nk : CARDINAL) ; FORWARD ;

(* ---------------------------------------------------------------- *)
(*  expressions  (TPSRC9)                                           *)
(* ---------------------------------------------------------------- *)

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

   A string literal is refused here, and this is the single place that has to:
   assignment, IF, WHILE, FOR, REPEAT, CASE, array subscripts and every
   operator all reach their operand through LoadAtom, and none of them can use
   a counted string where a 16-bit word is expected.  Reporting it here rather
   than in the parser means writeln('hi') still works - IoCall handles a
   literal before it ever calls LoadAtom. *)
BEGIN
   IF r.cls = TString THEN
      Err (ENoLib) ;                    (* string value used as a number *)
      r.kind := 2 ;
      RETURN
   END ;
   IF r.kind = 0 THEN
      EmMovAxi (W16 (r.imm)) ;
      r.kind := 2
   ELSIF r.kind = 1 THEN
      IF symtab [r.idx].size > 2 THEN
         Err (ENoLib)
      ELSE
         EmLoadVar (symtab [r.idx].local,
                    (symtab [r.idx].off + r.boff) MOD 10000H,
                    symtab [r.idx].size) ;
         IF symtab [r.idx].size = 1 THEN
            EmMovAh0 ()
         END ;
         r.kind := 2
      END
   END
END LoadAtom ;

PROCEDURE ParseSub (VAR r : ERes) ;
(* consume '[' constExpr ']' while present, folding the index into the
   base offset (constant indexing only) *)
VAR t : ERes ;
BEGIN
   LOOP
      Skip () ;
      IF CurCh () # '[' THEN
         RETURN
      END ;
      DropCh (GetCh ()) ;
      ParseExpr (t) ;
      IF OK () THEN
         IF t.kind # 0 THEN
            Err (ENoLib) ;
            RETURN
         END ;
         IF symtab [r.idx].cls = TArray THEN
            r.boff := W16 (VAL (LONGINT, r.boff)
                           + t.imm * VAL (LONGINT, symtab [r.idx].elem))
         ELSE
            Err (ESimpType) ;
            RETURN
         END
      END ;
      ExpectDelim (']', ENoSemi)
   END
END ParseSub ;

PROCEDURE ParseVar (VAR r : ERes) ;
(* name [ '[' constExpr ']' ]* ; a function name maps to its result var *)
VAR idx : CARDINAL ;
BEGIN
   IF NOT Search (wrd, idx) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   r.idx := idx ;
   r.kind := 1 ;
   r.boff := 0 ;
   r.cls := symtab [idx].cls ;
   IF symtab [idx].tag = KFunc THEN
      idx := symtab [idx].resvar ;
      r.idx := idx ;
      r.cls := symtab [idx].cls
   ELSIF (symtab [idx].tag # KVar) AND (symtab [idx].tag # KType) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   ParseSub (r)
END ParseVar ;

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

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

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

PROCEDURE EmMoveAxDx () ;
BEGIN
   Ebyte (92H)
END EmMoveAxDx ;

PROCEDURE BinOpEmit (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ;
(* binary operation at one precedence level; folds constant operands *)
VAR f : LONGINT ;
    okc : BOOLEAN ;
BEGIN
   IF op = TkAnd THEN
      IF (left.kind = 0) AND (right.kind = 0) THEN
         res.kind := 0 ;
          res.imm := BitAnd (left.imm, right.imm) ;
         res.cls := TBool ;
         RETURN
      END ;
      LoadAtom (left) ; EmPushAx () ;
      LoadAtom (right) ; EmPopCx () ;
      EmAndAxCx () ;
      res.kind := 2 ; res.cls := TBool ;
      RETURN
   END ;
   IF op = TkOr THEN
      IF (left.kind = 0) AND (right.kind = 0) THEN
         res.kind := 0 ;
         res.imm := BitOr (left.imm, right.imm) ;
         res.cls := TBool ;
         RETURN
      END ;
      LoadAtom (left) ; EmPushAx () ;
      LoadAtom (right) ; EmPopCx () ;
      EmOrAxCx () ;
      res.kind := 2 ; res.cls := TBool ;
      RETURN
   END ;
   IF (left.kind = 0) AND (right.kind = 0) THEN
      okc := FALSE ;
      CASE op OF
         1 : f := ConstAdd (left.imm, right.imm) ; okc := TRUE ;
      |  2 : f := ConstSub (left.imm, right.imm) ; okc := TRUE ;
      |  3 : f := ConstMul (left.imm, right.imm) ; okc := TRUE ;
      |  TkDiv : okc := (right.imm # 0) AND (right.imm > 0)
                        AND (left.imm >= 0) ;
                 IF okc THEN f := left.imm DIV right.imm END ;
      |  TkMod : okc := (right.imm # 0) AND (right.imm > 0)
                        AND (left.imm >= 0) ;
                 IF okc THEN f := left.imm MOD right.imm END ;
      ELSE
         okc := FALSE
      END ;
      IF okc THEN
         res.kind := 0 ;
         res.imm := VAL (LONGINT, W16 (f)) ;
         res.cls := left.cls ;
         RETURN
      ELSIF op = TkDiv THEN
         Err (EConstRange) ;
         RETURN
      END
   END ;
   LoadAtom (left) ; EmPushAx () ;
   LoadAtom (right) ; EmPopCx () ;
   EmXchgAxCx () ;
   CASE op OF
      1   : EmAddAxCx ;
   |  2   : EmSubAxCx ;
   |  3   : EmMulAxCx ;
   |  TkDiv : EmIDivAxCx ;
   |  TkMod : EmIDivAxCx ; EmMoveAxDx ;
   ELSE
      Err (ETypeErr)
   END ;
   res.kind := 2 ;
   res.cls := left.cls
END BinOpEmit ;

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

PROCEDURE ParseCmp (VAR r : ERes) ;
(* "=" | "<>" | "<" | "<=" | ">" | ">=" *)
VAR op : CARDINAL ;
    left, right : ERes ;
    f : LONGINT ;
BEGIN
   ParseAdd (r) ;
   LOOP
      op := 0 ;
      Skip () ;
      IF CurCh () = '=' THEN
         op := 1 ; DropCh (GetCh ())
      ELSIF (CurCh () = '<') AND (PeekAhead (1) = '>') THEN
         op := 2 ; DropCh (GetCh ()) ; DropCh (GetCh ())
      ELSIF CurCh () = '<' THEN
         IF PeekAhead (1) = '=' THEN
            op := 6 ; DropCh (GetCh ()) ; DropCh (GetCh ())
         ELSE
            op := 3 ; DropCh (GetCh ())
         END
      ELSIF CurCh () = '>' THEN
         IF PeekAhead (1) = '=' THEN
            op := 5 ; DropCh (GetCh ()) ; DropCh (GetCh ())
         ELSE
            op := 4 ; DropCh (GetCh ())
         END
      END ;
      IF op = 0 THEN
         RETURN
      END ;
      left := r ;
      ParseAdd (right) ;
      IF (left.kind = 0) AND (right.kind = 0) THEN
         IF ConstCmp (op, left.imm, right.imm, f) THEN
            r.kind := 0 ;
            r.imm := f ;
            r.cls := TBool
         ELSE
            r.kind := 0 ;
            r.imm := 0 ;
            r.cls := TBool
         END
      ELSE
         LoadAtom (left) ; EmPushAx () ;
         LoadAtom (right) ; EmPopCx () ;
         EmXchgAxCx () ;
         EmCmpAxCx () ;
         CASE op OF
            1 : EmSetcc (94H) ;
         |  2 : EmSetcc (95H) ;
         |  3 : EmSetcc (9CH) ;
         |  4 : EmSetcc (9DH) ;
         |  5 : EmSetcc (9FH) ;
         |  6 : EmSetcc (9EH)
         END ;
         r.kind := 2 ;
         r.cls := TBool
      END
   END
END ParseCmp ;

PROCEDURE ParseAdd (VAR r : ERes) ;
VAR op : CARDINAL ;
    left, right : ERes ;
BEGIN
   ParseMul (r) ;
   LOOP
      op := 0 ;
      Skip () ;
      IF CurCh () = '+' THEN
         op := 1 ; DropCh (GetCh ())
      ELSIF CurCh () = '-' THEN
         op := 2 ; DropCh (GetCh ())
      ELSIF KwAhead ("OR") THEN
         GetWord () ;
         op := TkOr
      ELSE
         RETURN
      END ;
      left := r ;
      ParseMul (right) ;
      BinOpEmit (op, left, right, r)
   END
END ParseAdd ;

PROCEDURE ParseMul (VAR r : ERes) ;
VAR op : CARDINAL ;
    left, right : ERes ;
BEGIN
   ParseNeg (r) ;
   LOOP
      op := 0 ;
      Skip () ;
      IF CurCh () = '*' THEN
         op := 1 ; DropCh (GetCh ())
      ELSIF CurCh () = '/' THEN
         op := 2 ; DropCh (GetCh ()) ; Err (ENoLib)
      ELSIF KwAhead ("DIV") THEN
         GetWord () ; op := TkDiv
      ELSIF KwAhead ("MOD") THEN
         GetWord () ; op := TkMod
      ELSIF KwAhead ("AND") THEN
         GetWord () ; op := TkAnd
      ELSE
         RETURN
      END ;
      IF op = 2 THEN
         RETURN
      END ;
      left := r ;
      ParseNeg (right) ;
      BinOpEmit (op, left, right, r)
   END
END ParseMul ;

PROCEDURE ParseNeg (VAR r : ERes) ;
BEGIN
   Skip () ;
   IF CurCh () = '+' THEN
      DropCh (GetCh ()) ;
      ParseNeg (r) ;
      RETURN
   ELSIF CurCh () = '-' THEN
      DropCh (GetCh ()) ;
      ParseNeg (r) ;
      IF r.kind = 0 THEN
         r.imm := VAL (LONGINT, W16 (0 - r.imm))
      ELSE
         LoadAtom (r) ;
         EmNegAx () ;
         r.kind := 2
      END ;
      RETURN
   ELSIF KwAhead ("NOT") THEN
      GetWord () ;
      ParseNeg (r) ;
      IF r.kind = 0 THEN
         r.imm := BitNot (r.imm)
      ELSE
         LoadAtom (r) ;
         EmNotAx () ;
         r.kind := 2
      END ;
      RETURN
   END ;
   ParseAtom (r)
END ParseNeg ;

PROCEDURE ParseAtom (VAR r : ERes) ;
(* const | variable | func(params) | '(' expr ')' *)
VAR idx : CARDINAL ;
    strf : BOOLEAN ;
    quoted : BOOLEAN ;
BEGIN
   r.chr := FALSE ;            (* default: not a quoted char literal *)
   Skip () ;
   IF CurCh () = '(' THEN
      DropCh (GetCh ()) ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      RETURN
   END ;
   IF (CurCh () = '$') OR (Digit (CurCh ())) OR (ORD (CurCh ()) = AposC) THEN
      (* remember that this was a quoted literal BEFORE RdConst consumes it:
         RdConst reports a 1-character literal as TScalar (its char code),
         which is right for "c := 'a'" but would make writeln('a') print 97.
         Mark it so the writer picks the char entry, not the integer one. *)
      quoted := (ORD (CurCh ()) = AposC) ;
      RdConst (r.imm, r.cls, strf) ;
      r.chr := quoted AND (r.cls = TScalar) AND NOT strf ;
      IF r.cls = TReal THEN
         Err (ENoLib) ;
         r.kind := 2 ;
         RETURN
      END ;
      IF strf THEN
         (* A string literal is legal here as a *value* - it is not rejected
            at this point, because writeln('hi') needs it and IoCall is the
            only place that knows how to emit one.  Everywhere else the
            literal has to end up as a machine word, and that is caught by
            LoadAtom, which refuses a TString. *)
         r.strx := rdStrX ;
         r.kind := 3 ;
         RETURN
      END ;
      r.kind := 0 ;
      RETURN
   END ;
   IF NOT Alpha (CurCh ()) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   GetWord () ;
   IF NOT Search (wrd, idx) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   IF symtab [idx].tag = KConst THEN
      r.kind := 0 ;
      r.imm := symtab [idx].lval ;
      r.cls := symtab [idx].cls ;
      RETURN
   ELSIF symtab [idx].tag = KFunc THEN
      ParseCall (idx) ;
      r.kind := 2 ;
      r.cls := symtab [idx].cls ;
      RETURN
   ELSIF (symtab [idx].tag = KVar) OR (symtab [idx].tag = KType) THEN
      ParseVar (r) ;
      r.boff := 0 ;
      RETURN
   ELSE
      Err (EUnknown)
   END
END ParseAtom ;

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

PROCEDURE EmCallMost (idx, nk : CARDINAL) ;
(* emit the call to sym 'idx' and clean up nk value arguments *)
VAR p : CARDINAL ;
BEGIN
   IF symtab [idx].defnd THEN
      DropC (EmCall (symtab [idx].goPos))
   ELSE
      p := EmCall (0) ;
      AddPend (1, idx, p)
   END ;
   IF nk > 0 THEN
      EmAddSp (2 * nk)
   END
END EmCallMost ;

PROCEDURE ParseCallArgs (idx : CARDINAL) ;
(* '(' already consumed: read args ')' then call.  Arguments are pushed
   right-to-left so the first-declared parameter lands at BP+4. *)
VAR args : ARRAY [0..15] OF ERes ;
    nArgs, i : CARDINAL ;
BEGIN
   nArgs := 0 ;
   IF CurCh () = ')' THEN
      DropCh (GetCh ())
   ELSE
      LOOP
         IF nArgs >= 16 THEN
            Err (ECompOvf) ;
            EXIT
         END ;
         ParseExpr (args [nArgs]) ;
         INC (nArgs) ;
         IF NOT MatchDelim (',') THEN
            EXIT
         END
      END ;
      ExpectDelim (')', ENoSemi)
   END ;
   i := nArgs ;
   WHILE i > 0 DO
      DEC (i) ;
      LoadAtom (args [i]) ;
      EmPushAx ()
   END ;
   EmCallMost (idx, nArgs)
END ParseCallArgs ;

PROCEDURE ParseCall (idx : CARDINAL) ;
(* procedure/function call; '(' optional *)
VAR args : ARRAY [0..15] OF ERes ;
    nArgs, i : CARDINAL ;
BEGIN
   nArgs := 0 ;
   IF MatchDelim ('(') THEN
      IF CurCh () # ')' THEN
         LOOP
            IF nArgs >= 16 THEN
               Err (ECompOvf) ;
               EXIT
            END ;
            ParseExpr (args [nArgs]) ;
            INC (nArgs) ;
            IF NOT MatchDelim (',') THEN
               EXIT
            END
         END ;
         ExpectDelim (')', ENoSemi)
      ELSE
         DropCh (GetCh ())
      END
   END ;
   i := nArgs ;
   WHILE i > 0 DO
      DEC (i) ;
      LoadAtom (args [i]) ;
      EmPushAx ()
   END ;
   EmCallMost (idx, nArgs)
END ParseCall ;

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

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

PROCEDURE ParseLabelStmt () ;
(* numeric label definition 'n :' *)
VAR n : CARDINAL ;
    nm : ARRAY [0..9] OF CHAR ;
    idx : CARDINAL ;
    i : CARDINAL ;
BEGIN
   n := 0 ;
   WHILE Digit (CurCh ()) DO
      n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ;
      DropCh (GetCh ())
   END ;
   ExpectDelim (':', ENoSemi) ;
   NumToName (n, nm) ;
   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 Assignment (r : ERes) ;
(* ':=' already consumed by the caller; store expression into r *)
VAR src : ERes ;
BEGIN
   IF r.kind # 1 THEN
      Err (EUnknown) ;
      RETURN
   END ;
   IF symtab [r.idx].size > 2 THEN
      Err (ENoLib) ;
      RETURN
   END ;
   ParseExpr (src) ;
   LoadAtom (src) ;
   EmStoreVar (symtab [r.idx].local,
               (symtab [r.idx].off + r.boff) MOD 10000H,
               symtab [r.idx].size)
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 IoCall (idx : CARDINAL) ;
(* WRITE / WRITELN / READ / READLN / HALT.

   TP3 (TPSRC8 pwriteln, pwrloop, prdtyped) does not pass a descriptor to
   the runtime: it looks at each argument's class and emits a *different*
   call per type, so the formatting is fixed at compile time.  Mirrored
   here - one call per argument, then a final call for the line break.

   WRITE/WRITELN push the value; READ/READLN push the address, so the
   runtime can store.  As everywhere else in this compiler the caller
   cleans the argument off the stack. *)
VAR args : ARRAY [0..15] OF ERes ;
    nArgs, i, ent, which, acls : CARDINAL ;
    reading : BOOLEAN ;
    pushed : BOOLEAN ;
    n : CARDINAL ;
    dummy : ERes ;
BEGIN
   which := symtab [idx].cls ;               (* BI_* *)
   IF which = BI_Halt THEN
      IF MatchDelim ('(') THEN               (* halt(0) - code ignored *)
         ParseExpr (dummy) ;
         ExpectDelim (')', ENoSemi)
      END ;
      DropC (EmCall (TU_Halt)) ;
      RETURN
   END ;
   reading := (which = BI_Read) OR (which = BI_ReadLn) ;
   nArgs := 0 ;
   IF MatchDelim ('(') THEN
      IF CurCh () # ')' THEN
         LOOP
            IF nArgs >= 16 THEN
               Err (ECompOvf) ;
               EXIT
            END ;
            ParseExpr (args [nArgs]) ;
            INC (nArgs) ;
            IF NOT MatchDelim (',') THEN
               EXIT
            END
         END ;
         IF NOT MatchDelim (')') THEN
            Err (ENoSemi) ;
            RETURN
         END
      ELSE
         DropCh (GetCh ())
      END
   END ;
   IF reading AND (nArgs = 0) THEN
      (* readln with no variable: just skip to the next line *)
      DropC (EmCall (TU_RdLn)) ;
      RETURN
   END ;
   (* NB: guard the loop bound - with nArgs = 0, "nArgs - 1" would wrap round
      to 65535 in CARDINAL and spin 65536 times. *)
   IF nArgs > 0 THEN
      FOR i := 0 TO nArgs - 1 DO
      pushed := TRUE ;      (* default: value is on the stack -> call + pop *)
      IF reading THEN
         IF args [i].kind # 1 THEN
            Err (ETypeErr) ;                  (* READ needs a variable *)
            RETURN
         END ;
         acls := symtab [args [i].idx].cls ;
         IF acls = TString THEN
            Err (ENoLib) ;                    (* string runtime pending *)
            RETURN
         END ;
         EmPushVarAddr (symtab [args [i].idx].local, symtab [args [i].idx].off) ;
         IF acls = TReal THEN
            ent := TU_RdInt                   (* real reads: not yet *)
         ELSIF acls = TBool THEN
            ent := TU_RdBool
         ELSIF acls = TScalar THEN
            ent := TU_RdInt
         ELSE
            ent := TU_RdChar
         END
      ELSE
         acls := args [i].cls ;
         IF (acls = TString) AND (args [i].kind = 3) THEN
            (* An inline string literal.  TP3 TPSRC8 pwrinlin special-cases a
               literal that is followed directly by ',' or ')' - i.e. an
               argument, not an expression - and emits
                  CALL wrtinl  <length byte> <characters...>
               with no stack argument at all; wrtinl reads the length from the
               return address and returns to just past the last character.
               Mirrored exactly, so the literal costs only its own characters
               in the code stream and nothing in the data segment. *)
            IF strLen [args [i].strx] > 255 THEN
               (* The length is one byte, so a literal of 256 characters or
                  more would wrap: 300 characters emitted behind a length of
                  44, and the runtime would print 44 of them and silently drop
                  the rest.  TP3 strings are at most 255 characters, so refuse
                  rather than truncate. *)
               Err (EConstRange) ;
               RETURN
            END ;
            DropC (EmCall (TU_WrInl)) ;
            Ebyte (VAL (BYTE, strLen [args [i].strx])) ;
            n := 0 ;
            WHILE n < strLen [args [i].strx] DO
               Ebyte (VAL (BYTE, ORD (strPool [strOff [args [i].strx] + n]))) ;
               INC (n)
            END ;
            pushed := FALSE                (* nothing was pushed for this one *)
         ELSE
            IF acls = TString THEN
               (* A string *variable*.  Not emitted rather than emitted wrongly:
                  EmPushVarAddr's local form is still wrong (see the note on
                  that procedure), and a wrong address here would print
                  garbage instead of failing. *)
               Err (ENoLib) ;
               RETURN
            END ;
            LoadAtom (args [i]) ;
            EmPushAx () ;
            IF args [i].chr THEN
               ent := TU_WrChar                (* 'a' - one char, not 97 *)
            ELSIF acls = TReal THEN
               ent := TU_WrReal
            ELSIF acls = TBool THEN
               ent := TU_WrBool
            ELSIF acls = TScalar THEN
               ent := TU_WrInt
            ELSE
               ent := TU_WrChar
            END
         END
      END ;
      IF pushed THEN
         DropC (EmCall (ent)) ;
         EmAddSp (2)                         (* one 16-bit argument *)
      END
      END
   END ;
   IF which = BI_WriteLn THEN
      DropC (EmCall (TU_WrLn))
   ELSIF which = BI_ReadLn THEN
      DropC (EmCall (TU_RdLn))
   END
END IoCall ;

PROCEDURE Statmnt () ;
VAR tok : CARDINAL ;
    idx, i2 : CARDINAL ;
    t, src : ERes ;
    L1, zj, zj2, exj : CARDINAL ;
    lo, hi, v : LONGINT ;
    clso : CARDINAL ;
    i : CARDINAL ;
    nm : ARRAY [0..MaxName] OF CHAR ;
    strf : BOOLEAN ;
    dow : BOOLEAN ;
BEGIN
   Skip () ;
   IF Digit (CurCh ()) THEN
      ParseLabelStmt () ;      (* consumed 'n' ':' *)
      Statmnt () ;             (* 'n : statement' - the statement follows
                                  the label directly, with no ';' between *)
      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 () ;
      IF MatchKey (tok) AND (tok = TkElse) THEN
         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) ;
      Statmnt () ;
      IF NOT (MatchKey (tok) AND (tok = TkUntil)) THEN
         Err (ENoSemi)
      END ;
      ParseExpr (t) ;
      LoadAtom (t) ;
      EmCmpAxi (0) ;
      zj := EmJcc (85H, L1) ;         (* JNZ -> 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) ;
      EmStoreVar (symtab [idx].local, 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 *)
      Statmnt () ;
      DEC (brkN) ;
      i := brkSave [brkN] ;
      WHILE i < exitCnt DO
         SetPatTgt (exitPatch [i], pc) ;
         INC (i)
      END ;
      exitCnt := brkSave [brkN] ;
      (* test then step: ax = var ; cx = bound (from [sp]) *)
      EmMovCxSp () ;
      EmLoadVar (symtab [idx].local, symtab [idx].off,
                 symtab [idx].size) ;
      EmCmpAxCx () ;
      IF dow THEN
         zj := EmJcc (8CH, 0)          (* JL -> done *)
      ELSE
         zj := EmJcc (8FH, 0)          (* JG -> done *)
      END ;
      EmLoadVar (symtab [idx].local, symtab [idx].off,
                 symtab [idx].size) ;
      IF dow THEN
         EmDecAx ()
      ELSE
         EmIncAx ()
      END ;
      EmStoreVar (symtab [idx].local, symtab [idx].off,
                  symtab [idx].size) ;
      DropC (EmJmpNear (L1)) ;
      SetPatTgt (zj, pc) ;             (* done: drop bound, continue *)
      EmAddSp (2)
   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 label : constant identifier or literal *)
         IF Alpha (CurCh ()) THEN
            GetWord () ;
            IF Search (wrd, i2) AND (symtab [i2].tag = KConst) THEN
               lo := symtab [i2].lval
            ELSE
               Err (EUnknown) ;
               EXIT
            END
         ELSE
            RdConst (lo, clso, strf)
         END ;
         IF MatchRange () THEN
            RdConst (hi, clso, strf)
         ELSE
            hi := lo
         END ;
         ExpectDelim (':', ENoSemi) ;
         EmMovAxSp () ;
         EmCmpAxi (W16 (lo)) ;
         zj := EmJcc (85H, 0) ;        (* JNZ -> next *)
         IF hi # lo THEN
            EmCmpAxi (W16 (hi)) ;
            zj2 := EmJcc (85H, 0)
         ELSE
            zj2 := 0
         END ;
         Statmnt () ;
         IF caseN >= 64 THEN
            Err (ECompOvf) ;
            EXIT
         END ;
         caseJmp [caseN] := EmJmpNear (0) ;
         INC (caseN) ;
         SetPatTgt (zj, pc) ;
         IF zj2 # 0 THEN
            SetPatTgt (zj2, pc)
         END
      END ;
      IF tok = TkElse THEN
         DropB (MatchKey (tok)) ;
         Statmnt () ;
         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 Digit (CurCh ()) THEN
         RdIntConst (v) ;
         NumToName (W16 (v), nm) ;
         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
      ELSE
         Err (EUnknown)
      END
   ELSIF tok = TkExit THEN
      IF brkN = 0 THEN
         Err (EUnknown)
      ELSE
         IF loopTy [brkN - 1] = 2 THEN
            EmAddSp (2)                (* drop FOR bound *)
         END ;
         zj := EmJmpNear (0) ;
         IF exitCnt < 64 THEN
            exitPatch [exitCnt] := zj ;
            INC (exitCnt)
         END
      END
   ELSIF tok = TkWith THEN
      Err (ENoLib)
   ELSE
      (* identifier statement: assignment or call *)
      IF NOT Search (wrd, idx) THEN
         Err (EUnknown) ;
         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 ;
         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 ;
    consumed : BOOLEAN ;
BEGIN
   cls := TNone ; size := 0 ; elem := 0 ;
   consumed := FALSE ;
   Skip () ;                (* after ':' / '=' : skip blanks *)
   IF Alpha (CurCh ()) THEN
      DropB (MatchKey (tok)) ;
      consumed := TRUE
   ELSE
      tok := TkNone
   END ;
   IF tok = TkArray THEN
      ExpectDelim ('[', ENoSemi) ;
      RdConst (lo, subcls, strf) ;
      IF NOT MatchRange () THEN
         Err (ESimpType)
      END ;
      RdConst (hi, subcls, strf) ;
      ExpectDelim (']', ENoSemi) ;
      IF NOT (MatchKey (tok) AND (tok = TkOf)) THEN
         Err (ENoSemi)
      END ;
      ParseType (cls, s2, e2) ;
      cls := TArray ;
      elem := s2 ;
      size := s2 * (W16 (VAL (LONGINT, W16 (hi))
                          - VAL (LONGINT, W16 (lo)) + 1))
   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
      Err (ENoLib) ;
      IF MatchKey (tok) AND (tok = TkOf) THEN
         ParseType (cls, s2, e2)
      END
   ELSIF tok = TkRecord THEN
      Err (ENoLib) ;
      LOOP
         PeekKw (tok) ;
         IF tok = TkEnd THEN
            DropB (MatchKey (tok)) ;
            EXIT
         END ;
         IF CurCh () = 0C THEN
            EXIT
         END ;
         Skip () ;
         IF Alpha (CurCh ()) THEN
            DropCh (GetCh ())
         ELSE
            DropCh (GetCh ())
         END
      END
   ELSIF (tok = TkFile) OR (tok = TkText) THEN
      cls := TFile ;
      size := 0 ;
      elem := 0 ;
      Err (ENoLib)
   ELSE
      IF consumed THEN
         IF Search (wrd, idx) AND (symtab [idx].tag = KType) THEN
            cls := symtab [idx].cls ;
            size := symtab [idx].size ;
            elem := symtab [idx].size
         ELSE
            Err (EUnknown)
         END
      ELSE
         (* subrange lo .. hi *)
         RdConst (lo, subcls, strf) ;
         IF NOT MatchRange () THEN
            Err (ESimpType) ;
            RETURN
         END ;
         RdConst (hi, subcls, strf) ;
         cls := TScalar ;
         size := 2 ;
         elem := 2
      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 ;
BEGIN
   LOOP
      Skip () ;                (* after the VAR keyword: skip blanks *)
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      LOOP
         GetWord () ;
         SaveWord (nm) ;
         DupTest (nm) ;
         IF NOT MatchDelim (':') THEN
            Err (ENoSemi)
         END ;
         ParseType (cls, size, elem) ;
         off := 0 ;
         IF lexnest = 0 THEN
            IF size > 2 THEN
               Err (ENoLib) ;
               RETURN
            END ;
            PeekKw (tok) ;
            IF tok = TkAbsolute THEN
               DropB (MatchKey (tok)) ;
               IF (CurCh () = '$') OR (Digit (CurCh ())) THEN
                  RdIntConst (v) ;
                  off := W16 (v)
               ELSE
                  Err (EUnknown)
               END
            ELSE
               off := dc ;
               dc := dc + size
            END ;
            DropC (NewSym (nm, KVar, cls, size, elem, off, 0, FALSE)) ;
            varspc := varspc + size
         ELSE
            IF size > 2 THEN
               Err (ENoLib) ;
               RETURN
            END ;
            DropC (NewSym (nm, KVar, cls, size, elem, locFree, 0, TRUE)) ;
            locFree := (locFree - size) MOD 10000H ;
            locBytes := locBytes + size
         END ;
         IF NOT MatchDelim (',') THEN
            EXIT
         END
      END ;
      IF NOT MatchDelim (';') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      PeekKw (tok) ;
      IF tok # TkNone THEN
         RETURN
      END
   END
END DefVar ;

PROCEDURE DefConst () ;
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    v : LONGINT ;
    cls : CARDINAL ;
    isStr : BOOLEAN ;
    tok : 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) ;
      ExpectDelim ('=', ENoSemi) ;
      RdConst (v, cls, isStr) ;
      IF isStr THEN
         Err (ENoLib)
      END ;
      DropC (NewSym (nm, KConst, cls, 0, 0, 0, v, FALSE)) ;
      IF NOT MatchDelim (';') THEN
         Err (ENoSemi) ;
         RETURN
      END
   END
END DefConst ;

PROCEDURE DefLabelPart () ;
VAR nm : ARRAY [0..9] OF CHAR ;
    n : CARDINAL ;
BEGIN
   LOOP
      Skip () ;
      IF NOT Digit (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      n := 0 ;
      WHILE Digit (CurCh ()) DO
         n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ;
         DropCh (GetCh ())
      END ;
      NumToName (n, nm) ;
      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 *)
BEGIN
   IF curIsFunc THEN
      IF OK () THEN
         EmLoadVar (TRUE, symtab [resultVar].off, symtab [resultVar].size)
      END
   END
END SymEpi ;

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 : BOOLEAN ;
    saveNest, saveLoc, saveRes, saveF : CARDINAL ;
    saveLB, savePO : CARDINAL ;
    i : 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)
      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 ;
   saveNest := lexnest ;
   saveLoc := locFree ;
   saveRes := resultVar ;
   saveF := VAL (CARDINAL, ORD (curIsFunc)) ;
   saveLB := locBytes ;
   savePO := parmOff ;
   INC (lexnest) ;
   locFree := 0FFFEH ;
   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) ;
            IF tok = TkVar THEN
               (* VAR parameter recorded as value in this milestone *)
               DropB (MatchKey (tok))
            END ;
            Skip () ;             (* blanks before the parameter name *)
            IF NOT Alpha (CurCh ()) THEN
               Err (EUnknown) ;
               RETURN
            END ;
            GetWord () ;
            SaveWord (parmNm) ;
            DupTest (parmNm) ;
            ExpectDelim (':', ENoSemi) ;   (* formal is 'name : type' *)
            ParseType (cls, size, elem) ;
            IF size > 2 THEN
               Err (ENoLib) ;
               RETURN
            END ;
            DropC (NewSym (parmNm, KVar, cls, size, elem, parmOff, 0, TRUE)) ;
            parmOff := parmOff + 2 ;
            IF NOT MatchDelim (',') THEN
               IF MatchDelim (')') THEN
                  EXIT
               END ;
               Err (ENoSemi) ;
               EXIT
            END
         END
      ELSE
         DropCh (GetCh ())
      END
   END ;
   IF isFunc THEN
      IF MatchDelim (':') THEN
         ParseType (cls, size, elem)
      ELSE
         cls := TScalar ;
         size := 2 ;
         elem := 2
      END ;
      IF size > 2 THEN
         Err (ENoLib) ;
         RETURN
      END ;
      symtab [old].cls := cls ;
      symtab [old].size := size ;
      resultVar := NewSym (nm, KVar, cls, size, elem, locFree, 0, TRUE) ;
      symtab [old].resvar := resultVar ;
      locFree := (locFree - size) MOD 10000H ;
      locBytes := locBytes + size
   END ;
   IfMatchSemi () ;
   PeekKw (tok2) ;
   IF (tok2 = TkForward) OR (tok2 = TkExternal) THEN
      DropB (MatchKey (tok2)) ;
      symtab [old].fwd := TRUE ;
      symtab [old].defnd := (tok2 = TkExternal) ;
      IfMatchSemi () ;
      lexnest := saveNest ;
      locFree := saveLoc ;
      resultVar := saveRes ;
      curIsFunc := (saveF # 0) ;
      locBytes := saveLB ;
      parmOff := savePO ;
      RETURN
   END ;
   (* body *)
   symtab [old].goPos := pc ;
   symtab [old].defnd := TRUE ;
   EmPushBp () ;
   EmMovBpSp () ;
   DefPart () ;                       (* nested declarations; stops at BEGIN *)
   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 ;
   lexnest := saveNest ;
   locFree := saveLoc ;
   resultVar := saveRes ;
   curIsFunc := (saveF # 0) ;
   locBytes := saveLB ;
   parmOff := savePO
END ProcFunc ;

PROCEDURE DefType () ;
(* 'name' '=' typeDef ; ... until a declaration keyword appears *)
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    cls, size, elem : 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) ;
      DupTest (nm) ;
      ExpectDelim ('=', ENoSemi) ;
      ParseType (cls, size, elem) ;
      IF NOT OK () THEN
         RETURN
      END ;
      DropC (NewSym (nm, KType, cls, size, elem, 0, 0, FALSE)) ;
      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
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 () ;
   (* Copy the runtime to the front of the code buffer and start pc past it,
      which is what the original does: TPSRC7 "copyrt" runs REPZ MOVSB with
      SI=DI=0 and then "MOV pc,#$2D7C".  The image is therefore

          [runtime][program header][program code]

      and because the runtime sits at 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.)

      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 () ;
   rt := RT_Size () ;
   IF rt >= MaxCode THEN
      Err (EMemOvf) ;                 (* cannot happen: rt is 385 *)
      RETURN
   END ;
   i := 0 ;
   WHILE i < rt DO
      cbuf [i] := RT_Byte (i) ;
      INC (i)
   END ;
   pc := rt ;
   rtSz := rt ;
   dataBase := rt + 1000H ;
   dc := dataBase ;
   strTop := 0 ;
   strCnt := 0 ;
   rdStrX := 0 ;
   varspc := 0 ;
   symTop := 0 ;
   nPatch := 0 ;
   nPend := 0 ;
   exitCnt := 0 ;
   brkN := 0 ;
   caseN := 0 ;
   lexnest := 0 ;
   curIsFunc := FALSE ;
   resultVar := 0 ;
   locFree := 0FFFEH ;
   locBytes := 0 ;
   parmOff := 4 ;
   dirs.rng := TRUE ;
   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, TScalar, 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)) ;
   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 ;
   (* 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. *)
   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_WrReal   := RT_Entry (6) ;
   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 *)
   IF (TU_WrInl = 0) OR (TU_RdLn = 0) OR (TU_WrInt = 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. *)
      Err (EMemOvf)
   END
END Inittur ;

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

PROCEDURE Compile (VAR errNo, errPos : CARDINAL) : BOOLEAN ;
VAR tok : CARDINAL ;
BEGIN
   Inittur () ;
   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 *)
      (* 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) ;
      DropC (EmCall (TU_InitMem)) ;
      EmMovBpSp () ;
      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
         DefPart () ;
         IF OK () THEN
            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. *)
                  PatchWord (hdrFlag, 1) ;
                  PatchWord (hdrCS, pc) ;
                  PatchWord (hdrDS, dataBase) ;
                  PatchWord (hdrHeap, dc) ;
                  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 program is NOT padded out to the data base here - the linker does
   that, and only it knows the .COM's final size. *)
BEGIN
   RETURN rtSz + codeSz
END ImageBytes ;

PROCEDURE DataBase () : CARDINAL ;
(* image-absolute offset at which the data area begins (rtSz + 1000H).  The
   linker must place the program's data here and zero-fill from the end of
   the code up to it. *)
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.