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, 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. *)

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

CONST
   MaxLine   = 128 ;
   MaxName   = 31 ;

   (* Size of the entry jump at image offset 0: E9 lo hi.  The jump's
      displacement is relative to the END of the jump, so every offset in the
      image is EntSize further along than it was before the jump existed. *)
   EntSize   = 3 ;
   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 ;
   (* CHAR needs a class of its own.  It used to be registered as TScalar,
      which made a CHAR variable indistinguishable from an INTEGER one: the
      class is all IoCall has to dispatch on, so `write(c)` called wrint (the
      value 65 became the *address* 65 and it printed whatever lived at 0x41)
      and `readln(c)` called rdint (which stores a 16-bit result, so it wrote
      two bytes into a one-byte variable).  TP3 TPSRC8 prdtyped/pwriteln
      dispatches on the type identifier for exactly this reason.  BYTE stays
      TScalar: a BYTE is written as an integer, as in TP3 - but a READ of one
      is dispatched on the variable's size instead (TPSRC8 prdnum
      `CMP varsize,#$01 / JA -> rdint, else rdbyte'), so the one thing class
      alone cannot tell apart is told apart where the size is in hand. *)
   TChar    = 12 ;

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

   (* Codes for the SYMBOL operators, as BinOpEmit numbers them.  The word
      operators carry their own Tk* token and need no code here.
      These are named, not bare numbers, because every precedence level's
      parser picks its own code out of the same set and BinOpEmit cannot see
      which level called it.  ParseAdd chose 1 for '+' and ParseMul chose 1
      for '*', so every multiplication dispatched to EmAddAxCx and a * b
      compiled to a + b.  Only the constant-folding path was right, which is
      why n * n with n a CONST was correct and a * b with a a variable was
      not. *)
   OpAdd = 1 ;  OpSub = 2 ;  OpMul = 3 ;

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

   (* Image offset of the entry jump's rel16 operand, patched at the end of
      Compile.  The jump is at image offset 0, so its displacement is simply
      the program code's end - 3. *)
   entRel, prologAt : CARDINAL ;

   (* Runtime entry offsets as IMAGE-ABSOLUTE addresses, which is what
      EmCall and EmJmp want.  They are derived from Runtime.RT_Entry in
      Inittur (after RT_Build, since RT_Entry only knows where the code
      landed once the blob is assembled) rather than written down, so a moved
      entry cannot leave the compiler calling the old address.  Not a CONST
      block 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_RdByte   : CARDINAL ;  (* one-byte variable reads; see IoCall *)
   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 ;       (* provisional parameter slot, in declaration
                                  order; remapped to TP3's BP+4 rule when the
                                  list has been read (see ProcFunc) *)

   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 JccShort (cc : BYTE) : BYTE ;
(* The 8086 SHORT Jcc opcode for a condition nibble.  70h..7Fh is exactly
   70h + nibble:  70 JO  71 JNO  72 JB  73 JAE  74 JE  75 JNE  76 JBE  77 JA
   78 JS  79 JNS  7A JP  7B JNP  7C JL  7D JGE  7E JLE  7F JG.
   So 70H + cc is the same condition the 386-only `0F 8x rel16' (for a Jcc) or
   `0F 9x' (for a SETcc) encoded, which is what lets the seven EmJcc sites and
   the six EmSetcc arms go on passing the low byte they always passed. *)
VAR n : CARDINAL ;
BEGIN
   n := VAL (CARDINAL, cc) MOD 10H ;
   RETURN VAL (BYTE, 70H + n)
END JccShort ;

PROCEDURE JccShortInv (cc : BYTE) : BYTE ;
(* The same, for a jump that is taken when the condition does NOT hold.
   EmJcc needs this one and EmSetcc needs the other, and the difference is the
   whole bug, so it is worth being explicit about where it comes from: the low
   bit of a Jcc code IS the negation bit.  4/5, C/D, E/F, 2/3, 6/7, A/9, B/8 and
   0/1 are the eight (condition, its negation) pairs, so negating a condition is
   `n XOR 1' and nothing more - `JE' and `JNE' are 0x74 and 0x75.

   Gm2 under -fiso has no XOR on integers at all: BITAND and BAND are both
   syntax errors, and arithmetic on a BYTE operand is rejected too, which is
   why every operand here goes through VAL.  n + 1 - 2*(n MOD 2) is XOR 1 for a
   four-bit n and it lives in one named place rather than open-coded, because
   an open-coded negation at two call sites is how they end up disagreeing. *)
VAR n : CARDINAL ;
BEGIN
   n := VAL (CARDINAL, cc) MOD 10H ;
   RETURN VAL (BYTE, 70H + n + 1 - 2 * (n MOD 2))
END JccShortInv ;

PROCEDURE EmJcc (cc : BYTE ; target : CARDINAL) : CARDINAL ;
(* A conditional branch, 8086 style.  `cc' is the condition nibble, and it is
   exactly the low byte of the `0F 8x rel16' this used to emit.

   That was a real fault and nothing in the build could see it: `0F' is a
   386-and-later opcode prefix and the 8086 has none, so EVERY conditional
   branch in EVERY compiled program was an illegal instruction on the machine
   TP3 targets.  FCML decoded it happily, because FCML's -m16 mode is 386 --
   and FCML is this project's independent disassembler, so the one tool that
   could have objected was the one guaranteed to agree.  qemu-system-i386 has
   no 8086 model either; its lowest is 486.  So the compile succeeded, the
   .COM linked, the layout checked, the golden held and all 30 fixtures ran to
   the right answers, all at once, with the bug in.

   TPSRC8 lays IF, WHILE and REPEAT out as

       MOV AL,brnchop ; MOV AH,#$03 ; CALL eword ; PUSH pc ; CALL ejump

   i.e. a SHORT Jcc of displacement 3, stepping over a 3-byte EJMP.  That is
   the shape here too, and EmJmpNear already owns the displacement arithmetic
   and the patch slot, so it is three lines and there is no second copy of
   that rule.

   The one thing that is NOT the same as TPSRC8, and cost a round of "every
   conditional is inverted" (t09_if printed pos/nonpos/lt for a program that
   must print nonpos/pos/ge): TP3's brnchop is the branch taken when the
   condition is TRUE, and TP3 steps over the EJMP when it is taken.  Here `cc'
   is the branch taken when the condition is FALSE -- IF's `EmJcc (84H)' is
   JZ, patched to the ELSE, so it must fire when the test failed.  EmJcc jumps
   to the target, it does not step over it, so stepping over an EJMP and then
   falling into the destination is the wrong way round: the byte has to be
   JccShortInv, not JccShort.  The control flow that comes out is identical to
   the `0F 8x' form this replaces; only which of the pair is spelled differs.

   The flags survive, and the FOR test needs them to: it emits CMP and then
   Jcc with nothing in between, so anything that wrote a flag here would
   break the loop.  Jcc and EJMP both leave the flags alone. *)
BEGIN
   Ebyte (JccShortInv (cc)) ;        (* Jcc_s, taken when cc does NOT hold *)
   Ebyte (03H) ;                     (* rel8: step over the 3-byte EJMP *)
   RETURN EmJmpNear (target)         (* target = 0 => forward, see above *)
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 () ;
(* Read the top of the stack into AX, leaving the stack unchanged.

   The obvious encoding, MOV AX,[SP], DOES NOT EXIST on the 8086.  There is
   no encoding of [SP] as a memory operand: SIB bytes, which is how [ESP]
   would be written, did not exist until the 386, and mod=00 / rm=100 is
   [SI], not [SP].  The first version of this emitted 8B 44 24 00 - mod=01,
   rm=100, SIB=24h, disp8=0 - which is correct only on a 386 and above.  Two
   of this project's oracles agree that it is wrong: fcml in 16-bit mode
   decodes it as MOV AX,[SI+0x24h], and so does qemu executing it, because
   qemu follows the CPU's rules for the encoding it is given rather than
   guessing.  It was not the encoder's fault that the bytes were well formed;
   they were, and they read SI+24h.

   The observable effect was that CASE compiled to no branches at all: each
   label test loaded a garbage address, every comparison failed, and the
   program fell straight past the whole statement and exited without printing.
   A CASE fixture caught it.  Nothing else could have - the encoding is
   valid, the size is right, and the byte-level checks have no way to know
   what register was meant.

   So: POP then PUSH the same value.  Two bytes, no SIB, correct on every
   8086, and observationally identical to peeking - the stack pointer ends
   where it started, holding the same value. *)
BEGIN
   Ebyte (58H) ;                     (* POP AX  *)
   Ebyte (50H)                      (* PUSH AX *)
END EmMovAxSp ;

PROCEDURE EmMovCxSp () ;
(* The same, for CX - the FOR loop's bound, pushed by the FOR statement and
   re-read on every iteration.  This one was emitting 8B 0C and nothing else,
   which is MOV CX,[SI] with the SIB slot missing: the *next* instruction was
   consumed as the SIB byte and the displacement.  Same root cause, same fix,
   and it had not been noticed only because no FOR fixture is executed yet. *)
BEGIN
   Ebyte (59H) ;                     (* POP CX  *)
   Ebyte (51H)                      (* PUSH CX *)
END EmMovCxSp ;

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

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

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

(* 91 = XCHG AX,CX, and NOT 93.  LoadPair hands the operator the left
   operand in CX and the right in AX (in the original, and still the
   commonest, shape: it pushes the left, loads the right, then pops the
   left into CX), so the exchange is what puts LEFT in AX for the
   operation to act on.
   Without it, `a - b` computes `b - a`; with the wrong register, `a + b`
   computes `AX' + a` where AX' is whatever BX happened to hold.

   This emitted 93H = XCHG BX,AX for its entire life, which is the same class
   of mistake as MovSiBx = 89 DC in Runtime.mod: the right opcode, the wrong
   ModRM, decoding cleanly.  Byte counts were right, the compile matrix was
   green, and no exec fixture did arithmetic on two variables - the first one
   to do so, `c := a + b` with a=7 b=5, printed 263 = 0100h+7, where 0100h
   was the caller's leftover BX.  The name was the only thing wrong, and
   nothing read the name: audit_helpers.py swept Runtime.mod and not
   Compiler.mod, which is where most of these emitters live.  It does both
   modules now. *)
PROCEDURE EmXchgAxCx () ;
BEGIN
   Ebyte (91H)
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 EmXorAl01 () ;
(* XOR AL,#01 - TPSRC9 neglevel's *boolean* NOT:

       CALL loadatom ; CALL ecode ; B $02,$34,$01

   neglevel tests the type first (CMP CL,#$0A -> integer -> NOT AX,
   CMP CL,#$0B -> boolean -> XOR AL,#01) and reports error 47 for anything
   else.  Emitting NOT AX for a boolean leaves 0FFFEh or 0FFFFh, and the
   runtime's wrbool tests [BP+4] <> 0, so `not (a = a)' came out TRUE. *)
BEGIN
   Ebyte (34H) ; Ebyte (01H)
END EmXorAl01 ;

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

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

PROCEDURE EmSetcc (cc : BYTE) ;
(* Flags -> a Boolean in AX, on an 8086.  `cc' is the SETcc opcode's low byte
   (94H = E, 95H = NE, 9CH = L, 9DH = GE, 9EH = LE, 9FH = G), i.e. the same
   condition nibble EmJcc takes.

   This used to emit `0F cc C0' - SETcc - which is 386-and-later, and then a
   MOV AH,0.  The 8086 cannot read its flags as a value at all, so there was
   nothing else to fall back on.

   TPSRC9's flgbool is the fallback, and emits exactly this for exactly this
   case (CH = 04h, a comparison whose result is wanted as a value rather than
   as a branch):

       CALL ecode ; B $03,$B8,$01,$00   ->  MOV AX,#0001
       MOV AL,brnchop ; CALL ebyte     ->  JNZ +1
       CALL ecode ; B $02,$01,$48      ->  DEC AX

   AX stays 1 because the DEC was stepped over, and becomes 0 because it ran.
   So the shape is one MOV, one short Jcc whose displacement is the length of
   the DEC, and the DEC - which is EmJcc's shape with a different displacement,
   and the reason both are two instructions and a byte.

   The polarity is the opposite of EmJcc's, and deliberately so: here the jump
   must be taken when the comparison is TRUE, because what is being asked is
   "is this comparison true", and the nibble the six ParseCmp arms pass is the
   comparison's own opcode.  So this is JccShort and EmJcc is JccShortInv --
   see EmJcc for why the difference is there at all.  TP3's flgbool writes JNZ
   for the same reason; in the one case IT reaches flgbool from, the boolean is
   sitting in AX rather than in the flags, so JNZ is how it says "AX is
   non-zero".

   AH comes out 0 for free, which is why the EmMovAh0 this used to end with is
   gone: 6 bytes here where the old sequence was 5.  The FLAGS do not survive,
   which the old SETcc did - and nothing reads them.  Every conditional branch
   in the compiler is preceded by its own CMP (see EmJcc's note on the FOR
   test), and a comparison's value is consumed either as an AX operand or by
   the test that follows it; the 30 executed fixtures are what holds that
   down, not this comment. *)
BEGIN
   Ebyte (0B8H) ; Eword (1) ;                           (* MOV AX,#0001 *)
   Ebyte (JccShort (cc)) ;            (* taken when the comparison HOLDS *)
   Ebyte (01H) ;                     (* rel8: step over the DEC AX *)
   Ebyte (48H)                                          (* DEC AX *)
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) ;
(* 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)
      ELSE
         Ebyte (0A0H) ; Eword ((off + LoadBias) MOD 10000H)
      END
   ELSE
      IF local THEN
         Ebyte (8BH) ; EmBpDisp (off)
      ELSE
         Ebyte (0A1H) ; Eword ((off + LoadBias) MOD 10000H)
      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 + LoadBias) MOD 10000H)
      END
   ELSE
      IF local THEN
         Ebyte (89H) ; EmBpDisp (off)
      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)
   ELSE
      Ebyte (8DH) ; Ebyte (06H) ; Eword ((off + LoadBias) MOD 10000H)
   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 ;

PROCEDURE HideLocals (from : CARDINAL) ;
(* Make every symbol from index `from' up invisible to everything outside the
   procedure that declared it.
   Search accepts a symbol when its level is <= lexnest, and every procedure
   body is compiled at the same depth (lexnest 1), so a finished procedure's
   parameters stayed visible to the NEXT procedure: a second `a : integer'
   was a duplicate (err 41) and an unqualified `a' inside procedure two read
   procedure one's argument.  Level 0FFFFH fails `level <= lexnest' at every
   depth a later procedure can be at, and by the time this runs the body that
   could still legitimately see them is finished.
   The symbols are relabelled, not popped: symtab[old].resvar holds an INDEX,
   and a function's result variable is one of the entries being hidden. *)
VAR p : CARDINAL ;
BEGIN
   p := from ;
   WHILE p < symTop DO
      symtab [p].level := 0FFFFH ;
      INC (p)
   END
END HideLocals ;

(* ---------------------------------------------------------------- *)
(*  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 DeclaresProc () : BOOLEAN ;
(* Does the REST of the source declare a PROCEDURE or a FUNCTION?

   Needed because the declaration part is compiled BEFORE the main statement
   part, so a procedure's code lands between the program prologue and the
   main body - and nothing jumps over it.  A program with a procedure
   therefore ran off the end of the prologue, straight into the first
   procedure, which read its argument out of an uninitialised frame and
   returned to address 0.  Every Pascal program containing a procedure was
   broken; `t13_proc` compiled and was never executed, so nothing saw it.

   The jump that fixes it has to be emitted BEFORE the declaration part, but
   whether one is needed is only known AFTER - so the only honest options are
   to emit it unconditionally (3 dead bytes in every program, and every code
   size in expected.tsv moves) or to know the answer in advance.  This is the
   second: it scans ahead and puts srcPos back.

   That is safe because the whole program is already in `src` and `srcPos` is
   a plain index into it - the same trick PeekKw and KwAhead use.  The scan
   looks for the keywords anywhere in the remainder rather than tracking the
   nesting of `begin`s, which is deliberately loose: a program with no
   procedures that merely mentions the word in a string literal would get a
   3-byte jump to the next instruction, which is harmless, whereas tracking
   the main `begin` against a procedure's `begin` would be a second parser
   to get wrong. *)
VAR save : CARDINAL ;
    found : BOOLEAN ;
    tk : CARDINAL ;
    ch : CHAR ;
BEGIN
   save := srcPos ;
   found := FALSE ;
   tk := TkNone ;                 (* so the answer is defined if src is empty *)
   (* Step over delimiters as well as blanks.  Stopping at the first
      non-letter looked reasonable and was wrong: `var x : integer ;` is full
      of ':' and ';', so the scan gave up inside the variable section and
      never reached the PROCEDURE.  The loop ends at the end of the source,
      not at the first punctuation. *)
   WHILE (NOT found) AND (srcPos < srcLen) DO
      Skip () ;
      IF Alpha (CurCh ()) THEN
         GetWord () ;
         tk := WddTok () ;
         IF (tk = TkProcedure) OR (tk = TkFunction) THEN
            found := TRUE
         END
      ELSE
         ch := GetCh ()                (* a ':' or ';' - step over it *)
      END
   END ;
   srcPos := save ;
   RETURN (tk = TkProcedure) OR (tk = TkFunction)
END DeclaresProc ;

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

PROCEDURE 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 ;
      LoadPair (left, right) ;
      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 ;
      LoadPair (left, right) ;
      EmOrAxCx () ;
      res.kind := 2 ; res.cls := TBool ;
      RETURN
   END ;
   IF (left.kind = 0) AND (right.kind = 0) THEN
      okc := FALSE ;
      CASE op OF
         OpAdd : f := ConstAdd (left.imm, right.imm) ; okc := TRUE ;
      |  OpSub : f := ConstSub (left.imm, right.imm) ; okc := TRUE ;
      |  OpMul : f := ConstMul (left.imm, right.imm) ; okc := TRUE ;
      |  TkDiv : okc := (right.imm # 0) AND (right.imm > 0)
                        AND (left.imm >= 0) ;
                 IF okc THEN f := left.imm DIV right.imm END ;
      |  TkMod : okc := (right.imm # 0) AND (right.imm > 0)
                        AND (left.imm >= 0) ;
                 IF okc THEN f := left.imm MOD right.imm END ;
      ELSE
         okc := FALSE
      END ;
      IF okc THEN
         res.kind := 0 ;
         res.imm := VAL (LONGINT, W16 (f)) ;
         res.cls := left.cls ;
         RETURN
      ELSIF op = TkDiv THEN
         Err (EConstRange) ;
         RETURN
      END
   END ;
   LoadPair (left, right) ;
   CASE op OF
      OpAdd : EmAddAxCx ;
   |  OpSub : EmSubAxCx ;
   |  OpMul : EmMulAxCx ;
   |  TkDiv : EmIDivAxCx ;
   |  TkMod : EmIDivAxCx ; EmXchgAxDx ;
   ELSE
      Err (ETypeErr)
   END ;
   res.kind := 2 ;
   res.cls := left.cls
END BinOpEmit ;

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

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

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

   Every binary level in this parser has the shape

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

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

   TPSRC9 does exactly this in the other order: addptr and mulptr CALL
   pushres (which calls loadatom and sets flgpshax) *before* CALL mullevel,
   so PUSH AX lands in the image ahead of the right-hand operand's code.
   Without this, `(p > q) or (q > p)` emitted both comparisons and then
   ORed the *second* comparison's result with itself - which is why it
   printed FALSE for TRUE or FALSE. *)
BEGIN
   IF left.kind = 2 THEN
      EmPushAx () ;
      left.kind := 4                      (* 4 = on the top of the stack *)
   END
END SaveLeft ;

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

   Three shapes, and only three:

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

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

PROCEDURE 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 ;
      SaveLeft (left) ;
      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
         LoadPair (left, right) ;
         EmCmpAxCx () ;
         (* The mnemonic is written next to every opcode on purpose.  `op' is
            a number, so the arm for ">" and the arm for ">=" differed only
            by two hex digits that are each one letter from the other
            meaning -- SETG (9FH) and SETGE (9DH).  They were swapped, which
            made a > b mean a >= b and a >= b mean a > b.  Only the equality
            boundary could see it: 6>5, 5<5, -1>-2 and every other case I
            tried were already right.  An opcode on its own does not say
            which comparison it is the answer to. *)
         CASE op OF
            1 : EmSetcc (94H) ;          (* =  SETE  *)
         |  2 : EmSetcc (95H) ;          (* <> SETNE *)
         |  3 : EmSetcc (9CH) ;          (* <  SETL  *)
         |  4 : EmSetcc (9FH) ;          (* >  SETG  *)
         |  5 : EmSetcc (9DH) ;          (* >= SETGE *)
         |  6 : EmSetcc (9EH)            (* <= SETLE *)
         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 := OpAdd ; DropCh (GetCh ())
      ELSIF CurCh () = '-' THEN
         op := OpSub ; DropCh (GetCh ())
      ELSIF KwAhead ("OR") THEN
         GetWord () ;
         op := TkOr
      ELSE
         RETURN
      END ;
      left := r ;
      SaveLeft (left) ;
      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 := OpMul ; DropCh (GetCh ())   (* OpAdd here meant a*b -> a+b *)
      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 ;
      SaveLeft (left) ;
      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) ;
      (* TPSRC9 neglevel branches on the operand's type before emitting
         anything: CMP CL,#$0A (integer) -> NOT AX, CMP CL,#$0B (boolean)
         -> XOR AL,#01, anything else -> error.  This used to emit NOT AX
         for both, so `not (a = a)' produced 0FFFEh and the runtime's
         wrbool test ([BP+4] <> 0) read it as TRUE.

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

PROCEDURE 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.

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

   Pushing in parse order is also the order the callee is laid out for: the
   first argument goes on first and so ends up farthest from BP, and the LAST
   declared parameter is the one at BP+4 (RESUME-TP3.md 3.11). *)
VAR arg : ERes ;
    nArgs : CARDINAL ;
BEGIN
   nArgs := 0 ;
   IF CurCh () = ')' THEN
      DropCh (GetCh ())
   ELSE
      LOOP
         IF nArgs >= 16 THEN
            Err (ECompOvf) ;
            EXIT
         END ;
         ParseExpr (arg) ;
         LoadAtom (arg) ;
         EmPushAx () ;
         INC (nArgs) ;
         IF NOT MatchDelim (',') THEN
            EXIT
         END
      END ;
      ExpectDelim (')', ENoSemi)
   END ;
   EmCallMost (idx, nArgs)
END ParseCallArgs ;

PROCEDURE ParseCall (idx : CARDINAL) ;
(* procedure/function call; '(' optional - same parse-then-push as above,
   reached from ParseAtom when a FUNCTION is called in an expression *)
VAR arg : ERes ;
    nArgs : CARDINAL ;
BEGIN
   nArgs := 0 ;
   IF MatchDelim ('(') THEN
      IF CurCh () # ')' THEN
         LOOP
            IF nArgs >= 16 THEN
               Err (ECompOvf) ;
               EXIT
            END ;
            ParseExpr (arg) ;
            LoadAtom (arg) ;
            EmPushAx () ;
            INC (nArgs) ;
            IF NOT MatchDelim (',') THEN
               EXIT
            END
         END ;
         ExpectDelim (')', ENoSemi)
      ELSE
         DropCh (GetCh ())
      END
   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 arg : ERes ;
    nArgs, 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 (arg) ;
            (* One argument at a time: parse it, give it its own push or its
               own runtime call, and only then read the next one.  TPSRC8
               pwrloop does exactly this, and it has to - a computed argument
               exists only in AX, so parsing the argument after it, and the
               call made for THIS one, are both free to destroy it.  Reading
               the whole list first and emitting afterwards printed the first
               argument as the last argument's value, and pushed an argument
               that an earlier inline string's call had already overwritten. *)
            pushed := TRUE ;      (* default: value is on the stack -> call + pop *)
            IF reading THEN
               IF arg.kind # 1 THEN
                  Err (ETypeErr) ;                  (* READ needs a variable *)
                  RETURN
               END ;
               acls := symtab [arg.idx].cls ;
               IF acls = TString THEN
                  Err (ENoLib) ;                    (* string runtime pending *)
                  RETURN
               END ;
               EmPushVarAddr (symtab [arg.idx].local, symtab [arg.idx].off) ;
               IF acls = TReal THEN
                  ent := TU_RdInt                   (* real reads: not yet *)
               ELSIF acls = TBool THEN
                  ent := TU_RdBool
               ELSIF acls = TChar THEN
                  ent := TU_RdChar                  (* one byte, not a word *)
               ELSIF acls = TScalar THEN
                  (* Dispatch on the SIZE, as TPSRC8 prdnum does:
                     `CMP varsize,#$01 / JA prdemit' keeps xrdint for
                     anything wider and falls through to `MOV AX,#xrdbyte'
                     for a one-byte variable.  A BYTE is still TScalar (it
                     is *written* as an integer, as in TP3), but reading one
                     through rdint stored a word - and the second byte of
                     that word is the byte that FOLLOWS the variable. *)
                  IF symtab [arg.idx].size = 1 THEN
                     ent := TU_RdByte
                  ELSE
                     ent := TU_RdInt
                  END
               ELSE
                  Err (ETypeErr) ;
                  RETURN
               END
            ELSE
               acls := arg.cls ;
               IF (acls = TString) AND (arg.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 [arg.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 [arg.strx])) ;
                  n := 0 ;
                  WHILE n < strLen [arg.strx] DO
                     Ebyte (VAL (BYTE, ORD (strPool [strOff [arg.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 (arg) ;
                  EmPushAx () ;
                  IF arg.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 = TChar THEN
                     ent := TU_WrChar                (* c : char - one char *)
                  ELSIF acls = TScalar THEN
                     ent := TU_WrInt
                  ELSE
                     Err (ETypeErr) ;
                     RETURN
                  END
               END
            END ;
            IF pushed THEN
               DropC (EmCall (ent)) ;
               EmAddSp (2)                         (* one 16-bit argument *)
            END ;
            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 ;
   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 () ;
      (* 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) ;
      Statmnt () ;
      IF NOT (MatchKey (tok) AND (tok = TkUntil)) THEN
         Err (ENoSemi)
      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) ;
      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: 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 () ;
      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 ;
      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 *)
      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: *)
      (* 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 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
         (* 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
      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) ;
      (* Unreachable, and it would be wrong even if it were reached: a
         speculative `MatchKey (tok) AND (tok = TkOf)` consumes the token it
         rejects.  See the note in the IF handler. *)
      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 ;
    nestMark : CARDINAL ;             (* symTop just inside this procedure *)
    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) ;
   nestMark := symTop ;          (* after the proc's own name, before its params *)
   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 ;
   (* 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 2 per parameter), so parameter k of n
      sat at 4 + 2*(k-1).  The map `off := parmOff + 2 - off' sends that to
      4 + 2*(n-k) - k = 1 to the far end, k = n to BP+4 - which is the layout
      above, with no offset invented and none lost.

      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 := parmOff + 2 - symtab [i].off ;
      INC (i)
   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 () ;
      HideLocals (nestMark) ;      (* a FORWARD's parameters are not the
                                      caller's to see either *)
      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 ;
   HideLocals (nestMark) ;         (* parameters and locals stop here *)
   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 () ;
   (* 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 := rtSz + 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, 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)) ;
   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.

      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_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 *)
   TU_RdByte   := RT_Entry (14) ;      (* a BYTE read stores one byte *)
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
      (* 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 () ;
      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 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.