TP3/shell/Compiler.mod

IMPLEMENTATION MODULE Compiler ;

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

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

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

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

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

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

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

FROM SYSTEM IMPORT BYTE, ADR ;

FROM Posix IMPORT open, read, close ;

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

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

(* ---------------------------------------------------------------- *)
(*  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 ;
   EIoHere    = 66 ;            (* I/O not allowed here - TPSRC8 prderrtp *)
   EFileNF    = 90 ;            (* File not found - TPSRC10 cdincl, errb *)
   EInclNest  = 96 ;            (* Illegal nesting of include files - TPSRC10 cdincl *)

   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),
                                       4 value on the stack (SaveLeft),
                                       5 string element, address in DI *)
         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 ;

   (* Include state.  srcName is the path the buffer was loaded from, set by
      SetSource; only its directory is used, because a {$I file} directive
      names the file relative to the INCLUDING file.  Includes are expanded by
      ExpandIncludes BEFORE parsing, so inclEnd is the end of the include
      region currently being scanned and inclActive says one is open - a
      nested {$I} inside that region is error 96, since TP3 permits only one
      level.  incBuf holds one whole include file while it is spliced. *)
   srcName    : ARRAY [0..255] OF CHAR ;
   inclName   : ARRAY [0..127] OF CHAR ;
   inclPath   : ARRAY [0..383] OF CHAR ;
   inclEnd    : CARDINAL ;
   inclActive : BOOLEAN ;
   incBuf     : ARRAY [0..TextLimit] OF CHAR ;

   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 ;

   (* TRUE once Compile has computed rtSz/dataBase, i.e. once the code window
      has been measured.  Ebyte refuses to write past dataBase (the 4 KiB code
      window) and needs to know the window is real before it can: dataBase is
      0 until it is set, and `pc >= 0' would abort on the very first byte. *)
   imgReady : BOOLEAN ;

   (* 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 *)
   TU_WrStr    : CARDINAL ;  (* string variable; address is the stack argument *)
   TU_RdStr    : CARDINAL ;  (* readln(s)/read(s); address on the stack, limit
                                in CX *)
   TU_StrStore : CARDINAL ;  (* s := t; dest and source addresses on the stack,
                                limit in CX *)
   TU_CmpStr   : CARDINAL ;  (* string comparison; two addresses on the stack,
                                signed -1/0/+1 in AX *)
   TU_StrCat   : CARDINAL ;  (* string concatenation; dest and source addresses
                                on the stack, limit in CX; exit code 16 if the
                                result would be too long *)

   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 ;

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

PROCEDURE SetSource (path : ARRAY OF CHAR) ;
(* remember the path the buffer was loaded from; MakeIncludePath keeps only its
   directory *)
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   WHILE (i < 255) AND (i <= HIGH (path)) AND (path [i] # 0C) DO
      srcName [i] := path [i] ;
      INC (i)
   END ;
   srcName [i] := 0C
END SetSource ;

PROCEDURE ReadWholeFile (path : ARRAY OF CHAR ; VAR n : CARDINAL) : BOOLEAN ;
(* Read path into incBuf with the same CR/LF normalisation as LoadWorkFile,
   and report its length in n.  FALSE if it could not be opened.  ^Z ends the
   text, as it does for every other reader here. *)
VAR fd : INTEGER ;
    k : LONGINT ;
    b : BYTE ;
    ch : CHAR ;
    prevCR, emit : BOOLEAN ;
BEGIN
   n := 0 ;
   fd := open (ADR (path), 0, 0) ;
   IF fd < 0 THEN
      RETURN FALSE
   END ;
   prevCR := FALSE ;
   LOOP
      k := read (fd, ADR (b), 1) ;
      IF k # 1 THEN EXIT END ;
      IF b = 26 THEN EXIT END ;            (* ^Z *)
      emit := TRUE ;
      IF b = 10 THEN
         IF prevCR THEN
            emit := FALSE
         ELSE
            ch := CHR (13)                 (* lone LF -> CR *)
         END ;
         prevCR := FALSE
      ELSIF b = 13 THEN
         ch := CHR (13) ;
         prevCR := TRUE
      ELSE
         ch := CHR (ORD (b)) ;
         prevCR := FALSE
      END ;
      IF emit AND (n <= TextLimit) THEN
         incBuf [n] := ch ;
         INC (n)
      END
   END ;
   k := close (fd) ;
   RETURN TRUE
END ReadWholeFile ;

PROCEDURE MakeIncludePath () ;
(* inclPath := directory (srcName) + inclName, defaulting the extension to
   .PAS when the name has none (TPSRC10 kpasext). *)
VAR i, j, last : CARDINAL ; dot : BOOLEAN ;
BEGIN
   dot := FALSE ;
   i := 0 ;
   WHILE (i < 127) AND (inclName [i] # 0C) DO
      IF inclName [i] = '.' THEN dot := TRUE END ;
      INC (i)
   END ;
   IF (NOT dot) AND (i <= 123) THEN
      inclName [i]     := '.' ;
      inclName [i + 1] := 'P' ;
      inclName [i + 2] := 'A' ;
      inclName [i + 3] := 'S' ;
      inclName [i + 4] := 0C
   END ;
   last := 0 ;
   i := 0 ;
   WHILE (i < 256) AND (srcName [i] # 0C) DO
      IF srcName [i] = '/' THEN last := i + 1 END ;
      INC (i)
   END ;
   j := 0 ;
   WHILE j < last DO
      inclPath [j] := srcName [j] ;
      INC (j)
   END ;
   i := 0 ;
   WHILE (i < 127) AND (inclName [i] # 0C) DO
      inclPath [j] := inclName [i] ;
      INC (j) ;
      INC (i)
   END ;
   inclPath [j] := 0C
END MakeIncludePath ;

PROCEDURE ExpandIncludes () ;
(* Replace every {$I name} directive in the buffer with the named file's text,
   BEFORE parsing.

   This is a pre-pass, and it has to be.  Skip is called by lookahead routines
   (DeclaresProc, PeekKw, KwAhead) that SAVE AND RESTORE srcPos; an include
   performed inside Skip would run once during the lookahead and once for real,
   and the second pass would see the first splice's text and report error 96.
   A splice also grows the buffer, which a rewind cannot undo.  So the whole
   expansion is done here, in one forward scan with no lookahead, and the
   parser only ever sees the finished text.

   The scan has to recognise exactly what the lexer does, or it would expand a
   directive that the lexer would have read as a string or a comment: a quoted
   literal is skipped, then star-paren comments (which is why {$I} written
   inside one is inert - t56_include.inc relies on that), then brace comments,
   and only then a brace directive.

   Divergence from the original: TP3 STREAMS the include file line by line and
   switches back to the outer file at EOF (TPSRC10 fileline/getincl/fileeof);
   we hold the whole source in TextBuf and address it by index, so the include
   is spliced in place.  A nested {$I} therefore cannot switch back on its own
   - which TP3 also refuses, and that is the error 96 reported here. *)
VAR i, d0, d1, k, ni, n : CARDINAL ;
    c, letter : CHAR ;
    isInc : BOOLEAN ;
BEGIN
   i := 0 ;
   inclActive := FALSE ;
   inclEnd := 0 ;
   WHILE (i < Length ()) AND OK () DO
      c := CharAt (i) ;
      IF c = "'" THEN
         INC (i) ;
         WHILE (i < Length ()) AND (CharAt (i) # "'") DO INC (i) END ;
         IF i < Length () THEN INC (i) END
      ELSIF (c = '(') AND (i + 1 < Length ()) AND (CharAt (i + 1) = '*') THEN
         INC (i, 2) ;
         WHILE (i < Length ()) AND NOT ((CharAt (i) = '*')
                     AND (i + 1 < Length ()) AND (CharAt (i + 1) = ')')) DO
            INC (i)
         END ;
         IF i < Length () THEN INC (i, 2) END
      ELSIF (c = '{') AND (i + 1 < Length ()) AND (CharAt (i + 1) = '$') THEN
         d0 := i ;
         d1 := i + 2 ;
         WHILE (d1 < Length ()) AND (CharAt (d1) # '}') DO INC (d1) END ;
         IF i + 2 < Length () THEN
            letter := Upper (CharAt (i + 2))
         ELSE
            letter := 0C
         END ;
         isInc := FALSE ;
         IF letter = 'I' THEN
            k := i + 3 ;
            WHILE (k < d1) AND ((CharAt (k) = ' ') OR (CharAt (k) = CHR (9))) DO
               INC (k)
            END ;
            IF (k >= d1) OR ((CharAt (k) # '+') AND (CharAt (k) # '-')) THEN
               isInc := TRUE
            END
         END ;
         IF isInc THEN
            IF inclActive AND (d0 < inclEnd) THEN
               srcPos := d0 ;
               Err (EInclNest) ;                  (* 96 *)
               RETURN
            END ;
            ni := 0 ;
            WHILE (k < d1) AND (ni < 127) DO
               inclName [ni] := CharAt (k) ;
               INC (k) ;
               INC (ni)
            END ;
            WHILE (ni > 0) AND ((inclName [ni - 1] = ' ')
                                OR (inclName [ni - 1] = CHR (9))) DO
               DEC (ni)
            END ;
            inclName [ni] := 0C ;
            MakeIncludePath () ;
            IF NOT ReadWholeFile (inclPath, n) THEN
               srcPos := d0 ;
               Err (EFileNF) ;                    (* 90 *)
               RETURN
            END ;
            DeleteFromTo (d0, d1 - d0 + 1) ;
            IF NOT InsertStr (d0, incBuf, n) THEN
               srcPos := d0 ;
               Err (EMemOvf) ;
               RETURN
            END ;
            inclEnd := d0 + n ;
            inclActive := TRUE ;
            i := d0                                 (* scan the new text too *)
         ELSE
            i := d1 + 1                             (* ordinary directive: leave it *)
         END
      ELSIF c = '{' THEN
         INC (i) ;
         WHILE (i < Length ()) AND (CharAt (i) # '}') DO INC (i) END ;
         IF i < Length () THEN INC (i) END
      ELSE
         INC (i)
      END
   END ;
   srcLen := Length () ;
   srcPos := 0
END ExpandIncludes ;

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

PROCEDURE Ebyte (b : BYTE) ;
BEGIN
   IF (pc >= MaxCode) OR (imgReady AND (pc >= dataBase)) THEN
      (* The image buffer bound, and the code window.  dataBase is a fixed
         4 KiB above the end of the runtime, so a program whose code reaches
         it has grown into its own data area - the two cannot share a 64 KiB
         .COM segment.  Reported as TP3's error 98 (memory overflow) rather
         than a silent truncation; see the layout note in Compile and
         SUMMARY.md "Known limit". *)
      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 EmMovCxi (imm : CARDINAL) ;
BEGIN
   Ebyte (0B9H) ; Eword (imm)
END EmMovCxi ;

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 EmOrAxAx () ;
(* 09 C0: OR AX,AX - the 8086's flag-only test of AX, and the one the string
   comparison needs, because cmpstr hands back a signed -1/0/+1 rather than
   flags.  OR AX,AX sets SF and ZF from the value and clears OF and CF, which
   is exactly the flag state a CMP AX,0 would leave - see EmSetcc and
   ParseCmp's EmRelSetcc.  TEST AX,AX (85 C0) does the same thing, but
   tests/audit_helpers.py's name grammar has no `Test' mnemonic, and an
   emitter that cannot be name-checked is worse than one that can.

   It is NOT EmXorAxAx: XORing AX with itself zeroes it, which would throw
   away the very value the flags are supposed to describe. *)
BEGIN
   Ebyte (09H) ; Ebyte (0C0H)
END EmOrAxAx ;

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 EmRelSetcc (op : CARDINAL) ;
(* The relational operator -> SETcc table, in ONE place, because there are now
   two callers: ParseCmp's numeric arm, whose flags come from EmCmpAxCx, and
   its string arm, whose flags come from a cmpstr result put through
   EmOrAxAx.  It was factored out of ParseCmp when the string arm arrived, and
   the note it carried is repeated here rather than referenced, because a
   comment in the caller about a table in another routine is a comment nobody
   reads.

   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 once, 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.

   `op' is ParseCmp's own numbering: 1 "=", 2 "<>", 3 "<", 4 ">", 5 ">=",
   6 "<=".  The condition nibbles are the SIGNED ones (L/G/GE/LE), and both
   callers hand it a value whose SIGN is the answer - ParseCmp's numeric arm
   compares with CMP AX,CX on signed data, and cmpstr answers -1/0/+1 - so
   the signed test is the right one in both places.  One table also means that
   swap cannot come back in one arm and not the other: tests/nonvacuity.sh
   mutates exactly these two lines, and it now breaks the string comparison
   at the same time as the numeric one. *)
BEGIN
   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
END EmRelSetcc ;

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

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

PROCEDURE EmBpDisp (off, regf : 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 packed top-anchored below BP:
       locFree is the highest still-free byte (0FFFFh = -1 at entry), a local of
       size n is based so its LAST byte sits on locFree, and locFree then drops
       by n.  So the first INTEGER local is at off = 0FFFEh = -2, the second at
       0FFFCh = -4, and so on - and a string local, which grows UP from its
       base, lands wholly below BP instead of straddling it.  The disp16 form
       reads those same two bytes as a signed value and addresses the negative
       slot 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
   (* mod=01 rm=110 -> 40H + regf*8 + 6H, mod=10 rm=110 -> 80H + regf*8 + 6H.
      regf is the ModR/M reg field: 0 when the opcode's register is the
      accumulator (every original caller), 7 for the DI forms EmLeaDi needs.
      rm is 110 ([BP+disp]) in both. *)
   IF off <= 127 THEN
      Ebyte (VAL (BYTE, 40H + regf * 8 + 6H)) ; Ebyte (VAL (BYTE, off))
   ELSE
      Ebyte (VAL (BYTE, 80H + regf * 8 + 6H)) ; 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, 0)
      ELSE
         Ebyte (0A0H) ; Eword ((off + LoadBias) MOD 10000H)
      END
   ELSE
      IF local THEN
         Ebyte (8BH) ; EmBpDisp (off, 0)
      ELSE
         Ebyte (0A1H) ; Eword ((off + LoadBias) MOD 10000H)
      END
   END
END EmLoadVar ;

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

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

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

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

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

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

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

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

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

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

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.  Include directives are already gone by the
   time Skip runs: ExpandIncludes splices them into the buffer first, so the
   {$I file} spelling never reaches here.  {$I+}/{$I-} still do, and stay the
   I/O-check toggle, exactly as TPSRC10 cdirec splits them on the sign. *)
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 := Upper (GetCh ()) ;
            IF CurCh () = '+' THEN
               ch := GetCh () ;
               IF letter = 'I' THEN dirs.chk := TRUE END ;
               IF letter = 'R' THEN dirs.rng := TRUE END
            ELSIF CurCh () = '-' THEN
               ch := GetCh () ;
               IF letter = 'I' THEN dirs.chk := FALSE END ;
               IF letter = 'R' THEN dirs.rng := 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 := Upper (GetCh ()) ;
            IF CurCh () = '+' THEN
               ch := GetCh () ;
               IF letter = 'I' THEN dirs.chk := TRUE END ;
               IF letter = 'R' THEN dirs.rng := TRUE END
            ELSIF CurCh () = '-' THEN
               ch := GetCh () ;
               IF letter = 'I' THEN dirs.chk := FALSE END ;
               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. *)
VAR emsz : CARDINAL ;
BEGIN
   IF r.cls = TString THEN
      Err (ENoLib) ;                    (* string value used as a number *)
      r.kind := 2 ;
      RETURN
   END ;
   IF r.kind = 5 THEN
      (* A string element with a variable index: ParseSub already computed its
         address into DI (LEA DI,[base] / ADD DI,AX), so the byte is at [DI].
         Zeroing AH keeps the value a clean 16-bit char, the same thing the
         size-1 load below does, because every consumer of a CHAR expects the
         high half to be zero.  The read must happen HERE, before anything
         else is emitted: the caller reaches this immediately after parsing
         the subscript, or - for a binary operator - SaveLeft has already
         materialised it, so DI is still the element's address. *)
      EmLdAlDi () ;
      EmMovAh0 () ;
      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) AND NOT
         ((r.cls = TChar) AND (symtab [r.idx].cls = TString)) THEN
         Err (ENoLib)
      ELSE
         (* s[i] indexes one byte of a string, not the string, so its width is
            one whatever the variable's declared width is. *)
         emsz := symtab [r.idx].size ;
         IF (r.cls = TChar) AND (symtab [r.idx].cls = TString) THEN
            emsz := 1
         END ;
         EmLoadVar (symtab [r.idx].local,
                    (symtab [r.idx].off + r.boff) MOD 10000H,
                    emsz) ;
         IF emsz = 1 THEN
            EmMovAh0 ()
         END ;
         r.kind := 2
      END
   END
END LoadAtom ;

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

   A CONSTANT index folds into the base offset boff, exactly as before.  A
   VARIABLE index on a STRING cannot fold - off+i is a run-time value - so it
   is computed once here into DI and r.kind drops to 5, which is how LoadAtom,
   Assignment and IoCall are told the element's address is in DI.  Arrays
   still accept only a constant index: a variable array subscript needs the
   element-size scaling that a one-byte string element does not, and it is
   item 2. *)
VAR t : ERes ;
BEGIN
   LOOP
      Skip () ;
      IF CurCh () # '[' THEN
         RETURN
      END ;
      DropCh (GetCh ()) ;
      ParseExpr (t) ;
      IF OK () THEN
         IF symtab [r.idx].cls = TString THEN
            (* s[i]: a STRING is a length byte at s[0] followed by the
               characters, so index i selects the one byte at off+i.  A second
               subscript on a character is not a type. *)
            IF r.cls = TChar THEN
               Err (ESimpType) ;
               RETURN
            END ;
            IF t.kind = 0 THEN
               (* constant index: fold it into boff, as an array's does, and
                  r.cls drops to TChar so every consumer below - LoadAtom,
                  Assignment, IoCall - sees a one-byte value instead of the
                  whole string. *)
               r.boff := W16 (VAL (LONGINT, r.boff) + t.imm)
            ELSE
               (* Variable index.  Compute the element address once, now:
                  the index is evaluated into AX (LoadAtom is a no-op for a
                  kind-2 value and re-reads [DI] for a nested subscript), then
                  DI := base + AX.  This is TP3's indstr/ialoop shape (TPSRC9
                  1100-1111, 1200-1229), which likewise holds the address in
                  DI until the byte is loaded or stored; a register is what
                  lets a later LoadAtom read [DI] and a later assignment PUSH
                  DI across its right-hand side. *)
               LoadAtom (t) ;
               EmLeaDi (symtab [r.idx].local,
                        (symtab [r.idx].off + r.boff) MOD 10000H) ;
               EmAddDiAx () ;
               r.kind := 5
            END ;
            r.cls := TChar
         ELSIF t.kind # 0 THEN
            Err (ENoLib) ;
            RETURN
         ELSIF 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 StrConcat (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ; FORWARD ;
PROCEDURE StrOperand (r : ERes) : BOOLEAN ; FORWARD ;

PROCEDURE BinOpEmit (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ;
(* binary operation at one precedence level; folds constant operands *)
VAR f : LONGINT ;
    okc : BOOLEAN ;
BEGIN
   IF StrOperand (left) OR StrOperand (right) THEN
      (* A string OPERAND - a STRING or a CHAR, which is a one-character string
         for this purpose - makes this a string operation, and `+' is the only
         one ISO Modula-2 defines: every other binary operator reached here
         (OR, and the multiplicative and additive numeric ops) has no meaning
         over a STRING, and StrConcat rejects it.

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

         Handling it here, at the head of the one routine every binary
         operator funnels through, is what keeps `a + b', `writeln(a + b)',
         `(a + b) = c' and `s := a + b + c' all going through the same
         emission. *)
      StrConcat (op, left, right, res) ;
      RETURN
   END ;
   IF op = TkAnd THEN
      IF (left.kind = 0) AND (right.kind = 0) THEN
         res.kind := 0 ;
          res.imm := BitAnd (left.imm, right.imm) ;
         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 *)
   ELSIF left.kind = 5 THEN
      (* A string element whose address is in DI.  This is the one place the
         address must be spent BEFORE the right-hand operand is parsed: DI
         cannot survive it, because the right operand may hold a subscript of
         its own (which reuses DI) or call a routine (which may clobber it).
         Reading [DI] now - which LoadAtom does, turning kind 5 into kind 2 -
         and pushing the value is exactly what the kind-2 case above does
         next, so the two branches converge on kind 4.  A subscript on the
         RIGHT is fine: it sets DI after this point and LoadPair reads it
         immediately, with no parse in between. *)
      LoadAtom (left) ;                   (* AL := [DI], AH := 0; kind := 2 *)
      EmPushAx () ;
      left.kind := 4
   END
END SaveLeft ;

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

   Three shapes, and only three:

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

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

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

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

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

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

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

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

   A 1-character literal is NOT a TString here: RdConst reports it as TScalar
   (its character code), so `s = 'a'` compares a string with a character and
   is a type error rather than a length-1 string compare.  That is deliberate
   - it is the same rule `c := 'a'` relies on - and the caller rejects it. *)
VAR n, len, here : CARDINAL ;
BEGIN
   IF r.kind = 1 THEN
      EmPushVarAddr (symtab [r.idx].local,
                     (symtab [r.idx].off + r.boff) MOD 10000H)
   ELSIF r.kind = 3 THEN
      len := strLen [r.strx] ;
      IF len > 255 THEN
         (* As in IoCall: the length is one byte, so a longer literal would
            wrap and silently compare only its first (length MOD 256)
            characters.  TP3 strings are at most 255 characters. *)
         Err (EConstRange) ;
         RETURN
      END ;
      IF len + 1 <= 127 THEN
         Ebyte (0EBH) ; Ebyte (VAL (BYTE, len + 1))    (* JMP rel8 over it *)
      ELSE
         Ebyte (0E9H) ; Eword (len + 1)                (* JMP rel16 over it *)
      END ;
      here := pc ;                 (* the length byte: the literal's address *)
      Ebyte (VAL (BYTE, len)) ;
      n := 0 ;
      WHILE n < len DO
         Ebyte (VAL (BYTE, ORD (strPool [strOff [r.strx] + n]))) ;
         INC (n)
      END ;
      EmPushVarAddr (FALSE, here)  (* LEA AX,[here]; PUSH AX *)
   ELSE
      Err (ENoLib)                 (* a computed string is not a value *)
   END
END EmPushStrAddr ;

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

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

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

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

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

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

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

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

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

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

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

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

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

PROCEDURE ParseCmp (VAR r : ERes) ;
(* "=" | "<>" | "<" | "<=" | ">" | ">=" *)
VAR op : CARDINAL ;
    left, right : ERes ;
    f : LONGINT ;
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.cls = TString) OR (right.cls = TString) THEN
         (* A string comparison: cmpstr, the entry TPSRC9's vcompare (133)
            reaches through TPSRC2's csteq/cstne/cstge/cstle/cstg/cstl
            wrappers (890-925).  It is intercepted BEFORE the constant-fold
            arm, because a string literal is never a kind-0 constant and,
            without this branch, both operands would fall through to LoadAtom,
            which refuses a TString (ENoLib) - the symptom this arm cures.

            cmpstr returns AX = -1/0/+1 (see Runtime.mod for why a value and
            not flags), so the second half is exactly the numeric arm's: put
            the sign in the flags and let the shared six-arm table answer.
            EmOrAxAx is OR AX,AX rather than EmCmpAxi(0) on purpose: tests/
            check_8086.py reads every `CMP AX,0000' in the program region as
            an IF/WHILE/REPEAT test and requires a branch right after it, and
            a comparison used as a VALUE (writeln(a = b)) is not one. *)
         IF (left.cls # TString) OR (right.cls # TString) THEN
            Err (ETypeErr) ;         (* a string compared with a number/char *)
            RETURN
         END ;
         EmPushStrAddr (left) ;
         EmPushStrAddr (right) ;
         DropC (EmCall (TU_CmpStr)) ;
         EmAddSp (4) ;
         EmOrAxAx () ;
         EmRelSetcc (op) ;
         r.kind := 2 ;
         r.cls := TBool
      ELSIF (left.kind = 0) AND (right.kind = 0) THEN
         IF ConstCmp (op, left.imm, right.imm, f) THEN
            r.kind := 0 ;
            r.imm := f ;
            r.cls := TBool
         ELSE
            r.kind := 0 ;
            r.imm := 0 ;
            r.cls := TBool
         END
      ELSE
         LoadPair (left, right) ;
         EmCmpAxCx () ;
         EmRelSetcc (op) ;
         r.kind := 2 ;
         r.cls := TBool
      END
   END
END 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 initialises boff to 0 and then ParseSub folds any constant
         subscript into it.  Do NOT reset boff here: doing so after ParseVar
         returns threw away the subscript, so s[i] read/wrote off+0 (the
         length byte) while still reporting itself as a char.  This was
         latent for arrays because an array cannot be declared yet, so no
         fixture had ever exercised the fold. *)
      ParseVar (r) ;
      RETURN
   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 ;
    k, n : CARDINAL ;
BEGIN
   IF (r.kind # 1) AND (r.kind # 5) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   IF (symtab [r.idx].cls = TString) AND (r.cls = TString) THEN
      (* s := <string literal>.  TPSRC8 asn2 sends a string through the scalar
         store path, and estcpl's string arm emits `MOV CL,max_len' (max_len =
         varsize-1) then `CALL strstore', which copies the source - length byte
         and characters - into the destination and TRUNCATES a source longer
         than max_len by rewriting the length byte (TPSRC2 strstore's
         `CMP.B CL,AL / JBE stslenok / MOV.B [SI],AL').  Here the literal is
         known at compile time, so its bytes become immediate stores instead of
         a stack push and a block move.  The variable that results is the same,
         truncation included, and the tail past the new length is left as it
         was, exactly as strstore leaves it. *)
      ParseExpr (src) ;
      IF (src.cls # TString) THEN
         Err (ENoLib) ;
         RETURN
      END ;
      IF src.kind # 3 THEN
         (* s := <string variable>.  TPSRC8 asnvar pushes the destination
            address, then the expression (strload) pushes the source, and
            estcpl emits MOV CL,max_len then CALL strstore, which copies
            length byte + chars, TRUNCATING to max_len and leaving the
            destination tail past the new length untouched.  Here both
            addresses are pushed - source first, so it sits at [BP+6] and the
            destination at [BP+4] - the caller pops both, and the limit is a
            full MOV CX,imm16 because this runtime reads it in CX outright. *)
         IF src.kind # 1 THEN
            Err (ENoLib) ;          (* a computed string is not a value *)
            RETURN
         END ;
         EmPushVarAddr (symtab [src.idx].local,
                        (symtab [src.idx].off + src.boff) MOD 10000H) ;
         EmPushVarAddr (symtab [r.idx].local,
                        (symtab [r.idx].off + r.boff) MOD 10000H) ;
         EmMovCxi ((symtab [r.idx].size - 1) MOD 10000H) ;
         DropC (EmCall (TU_StrStore)) ;
         EmAddSp (4) ;
         RETURN
      END ;
      n := strLen [src.strx] ;
      IF n > symtab [r.idx].size - 1 THEN
         n := symtab [r.idx].size - 1
      END ;
      EmMovAxi (n) ;
      EmStoreVar (symtab [r.idx].local,
                  (symtab [r.idx].off + r.boff) MOD 10000H, 1) ;
      k := 0 ;
      WHILE k < n DO
         EmMovAxi (ORD (strPool [strOff [src.strx] + k])) ;
         EmStoreVar (symtab [r.idx].local,
                     (symtab [r.idx].off + r.boff + 1 + k) MOD 10000H, 1) ;
         INC (k)
      END ;
      RETURN
   END ;
   IF symtab [r.idx].size > 2 THEN
      IF (r.cls # TChar) OR (symtab [r.idx].cls # TString) THEN
         Err (ENoLib) ;
         RETURN
      END ;
      (* s[i] := c : one byte, either at off+boff (a constant index) or at [DI]
         (a variable one, r.kind = 5).  The whole-string path above was skipped
         because r.cls is TChar, not TString, so this is the element store; a
         plain char variable has size 1 and takes the scalar path below
         instead.

         For a variable index the destination address is in DI, and the
         right-hand side is parsed next, so DI has to be saved first - the RHS
         may hold a subscript of its own, which reuses DI, or call a routine
         that clobbers it.  This is TPSRC8 asnscal2/asnscal3 (758-760,
         786-789), which set flgpshdi around the expression for the same
         reason.  After the save, DI is free for the RHS, and the store reads
         it back. *)
      IF r.kind = 5 THEN
         EmPushDi ()
      END ;
      ParseExpr (src) ;
      LoadAtom (src) ;
      IF r.kind = 5 THEN
         EmPopDi () ;                    (* DI := the destination again *)
         EmStDiAl ()                     (* [DI] := AL *)
      ELSE
         EmStoreVar (symtab [r.idx].local,
                     (symtab [r.idx].off + r.boff) MOD 10000H, 1)
      END ;
      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) ;
            IF NOT OK () THEN
               (* An argument that did not type-check has no value and arg.idx
                  is not a symbol.  The string arm below dereferences
                  symtab[arg.idx] for ANY value whose class is TString - unlike
                  the string assign in Assignment, which can tell a failed
                  concat from a real one by its kind - so a `writeln' of a
                  rejected expression read symtab with whatever idx held
                  before and dereferenced it.  That is exactly how
                  `writeln('a' + 'b')' - two CHARs, a type error since
                  v-TP3-STRCAT - segfaulted the compiler instead of reporting
                  the error.  ParseSub guards its subscript the same way (see
                  `IF OK () THEN' before symtab[r.idx] there), and the
                  statement loop stops at the next iteration, so leaving the
                  rest of this WRITELN unparsed is harmless. *)
               RETURN
            END ;
            (* 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) AND (arg.kind # 5) THEN
                  Err (ETypeErr) ;                  (* READ needs a variable *)
                  RETURN
               END ;
               acls := symtab [arg.idx].cls ;
               (* s[i] is a CHAR variable, so read(s[i]) must read one byte at
                  off+boff, not the whole string at off.  arg.cls is TChar
                  (set by ParseSub) while the symbol's own class is still
                  TString, which is exactly how the element is told from the
                  whole string; the address push has to carry boff.  For a
                  plain variable arg.boff is 0, so nothing changes. *)
               IF (acls = TString) AND (arg.cls = TChar) THEN
                  acls := TChar
               END ;
               IF arg.kind = 5 THEN
                  (* A variable index: ParseSub computed the element's address
                     into DI, and nothing has been emitted since, so that is
                     the address READ wants.  A constant index folds into boff
                     and takes the LEA path below. *)
                  EmPushDi ()
               ELSE
                  EmPushVarAddr (symtab [arg.idx].local,
                                 (symtab [arg.idx].off + arg.boff) MOD 10000H)
               END ;
               IF acls = TString THEN
                  (* readln(s)/read(s) of a string variable: TPSRC8 prdstr
                     pushes the address, emits MOV CL,max_len and CALL
                     xrdstr.  Here the limit is a full MOV CX,imm16 (this
                     runtime has no byte-register CH/CL setup), and rdstr
                     leaves the terminator pending so the readln wrapper can
                     consume the newline. *)
                  EmMovCxi ((symtab [arg.idx].size - 1) MOD 10000H) ;
                  ent := TU_RdStr
               ELSIF acls = TReal THEN
                  ent := TU_RdInt                   (* real reads: not yet *)
               ELSIF acls = TBool THEN
                  (* TP3 refuses boolean I/O: TPSRC8 prderrtp is error 66,
                     "I/O not allowed here", and the runtime has no xrdbool
                     at all.  rdbool stores a WORD, so one byte of an
                     accepted read would land on the variable AFTER b - the
                     exact overflow t37_readbyte pins for a byte.  TP3's
                     answer to the whole class is the error; so is ours. *)
                  Err (EIoHere) ;
                  RETURN
               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*.  Its value IS its address, so it is
                        passed exactly the way READ passes an address: push it
                        and call the owner of the layout - wrstr - which reads
                        the length byte and prints that many characters.  TPSRC8
                        pwrstr/pwrchk route a string argument to xwrtstr, and
                        xwrtstr reaches its argument through BP just like WrChar
                        does.  The only difference from the inline-literal arm
                        above is where the bytes live: a literal's are in the
                        code stream (wrtinl) and a variable's are in the data
                        segment or the frame (wrstr). *)
                     EmPushVarAddr (symtab [arg.idx].local, symtab [arg.idx].off) ;
                     ent := TU_WrStr
                  ELSE
                     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
            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 ;
    first, i : CARDINAL ;
BEGIN
   LOOP
      Skip () ;                (* after the VAR keyword: skip blanks *)
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      (* A group is `name (, name)* : type' - TPSRC7 rdvarlst/rdvloop collects
         the whole comma-separated list of names FIRST (`CALL ccomma / JZ
         rdvloop'), then reads one `: type' with ecolon/rdvartp, then vardef2
         gives every name in the list that one type.  The names are created as
         placeholders here and filled in once the type is known, which is the
         same shape as TP3 reserving a symtab slot per name and storing the
         type pointer into each afterwards. *)
      first := symTop ;
      LOOP
         Skip () ;             (* GetWord does not skip blanks, and the cursor
                                  sits on the space after the ',' *)
         IF NOT Alpha (CurCh ()) THEN
            Err (EUnknown) ;
            RETURN
         END ;
         GetWord () ;
         SaveWord (nm) ;
         DupTest (nm) ;
         DropC (NewSym (nm, KVar, TNone, 0, 0, 0, 0, lexnest # 0)) ;
         IF NOT MatchDelim (',') THEN
            EXIT
         END
      END ;
      ExpectDelim (':', ENoSemi) ;
      ParseType (cls, size, elem) ;
      IF OK () THEN
         IF lexnest = 0 THEN
            IF (size > 2) AND (cls # TString) THEN
               (* Still the catch-all for a type whose storage this compiler does
                  not lay out yet (an ARRAY at its point of use, a RECORD, ...).
                  A STRING is the exception now: its layout is length byte +
                  characters, and the rest of the compiler knows it - see
                  Assignment and IoCall. *)
               Err (ENoLib) ;
               RETURN
            END ;
            PeekKw (tok) ;
            IF tok = TkAbsolute THEN
               DropB (MatchKey (tok)) ;
               IF (CurCh () = '$') OR (Digit (CurCh ())) THEN
                  RdIntConst (v) ;
                  off := W16 (v)
               ELSE
                  Err (EUnknown) ;
                  off := 0
               END ;
               (* TP3's absolute path (vdstore) leaves the offset fixed, so
                  every name in the group aliases the same address. *)
               i := first ;
               WHILE i < symTop DO
                  symtab [i].cls := cls ; symtab [i].size := size ;
                  symtab [i].elem := elem ; symtab [i].off := off ;
                  INC (i)
               END
            ELSE
               i := first ;
               WHILE i < symTop DO
                  symtab [i].cls := cls ; symtab [i].size := size ;
                  symtab [i].elem := elem ; symtab [i].off := dc ;
                  dc := dc + size ;
                  INC (i)
               END
            END ;
            varspc := varspc + size * (symTop - first)
         ELSE
            IF (size > 2) AND (cls # TString) THEN
               Err (ENoLib) ;
               RETURN
            END ;
            (* A local occupies [off, off+size-1] and lives BELOW the saved BP,
               because BP-relative locals grow down from the top of the frame
               while a STRING grows UP from its base (length byte, then chars).
               Top-anchored packing keeps both true at once: locFree is the
               highest still-free byte (-1 at the top), the new symbol's base
               is placed so that its LAST byte lands on that byte, and locFree
               then drops by the whole size.  So the first INTEGER (size 2) is
               at -2 and the second at -4, byte for byte what the old
               pre-decrement rule produced, while a string[5] local (size 6) is
               at -6..-1 instead of the old -2..+3 - which straddled the saved
               BP at [BP] and the return address at [BP+2] and made `readln(s)'
               into a local store characters over its own return address.
               Each name in the group gets its own slot. *)
            i := first ;
            WHILE i < symTop DO
               symtab [i].cls := cls ; symtab [i].size := size ;
               symtab [i].elem := elem ;
               symtab [i].off := (locFree - size + 1) MOD 10000H ;
               locFree := (locFree - size) MOD 10000H ;
               INC (i)
            END ;
            locBytes := locBytes + size * (symTop - first)
         END
      END ;
      IF MatchDelim (',') THEN
         (* The older `name : type, name : type' spelling: another group
            follows without a semicolon.  TP3's grammar is names-then-one-type
            with ',' inside a group and ';' between groups (TPSRC7 rdvarlst /
            rdvloop then ecolon/rdvartp), and both spellings reach the same
            symbols, so both separators are accepted here. *)
      ELSIF MatchDelim (';') THEN
         PeekKw (tok) ;
         IF tok # TkNone THEN
            RETURN
         END
      ELSE
         Err (ENoSemi) ;
         RETURN
      END
   END
END DefVar ;

PROCEDURE DefConst () ;
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    v : LONGINT ;
    cls : 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, first : CARDINAL ;
BEGIN
   isFunc := curIsFunc ;
   Skip () ;                   (* after the PROCEDURE/FUNCTION keyword *)
   IF NOT Alpha (CurCh ()) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   GetWord () ;
   SaveWord (nm) ;
   IF Search (nm, idx) AND (symtab [idx].tag = KProc)
      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 := 0FFFFH ;
   locBytes := 0 ;
   parmOff := 4 ;
   IF MatchDelim ('(') THEN
      IF CurCh () # ')' THEN
         LOOP
            (* PeekKw, not MatchKey: MatchKey CONSUMES the word it reads, so
               using it to test for VAR would eat the parameter's name. *)
            PeekKw (tok) ;
            IF tok = TkVar THEN
               (* VAR parameter recorded as value in this milestone *)
               DropB (MatchKey (tok))
            END ;
            first := symTop ;
            LOOP
               Skip () ;          (* blanks before the parameter name *)
               IF NOT Alpha (CurCh ()) THEN
                  Err (EUnknown) ;
                  RETURN
               END ;
               GetWord () ;
               SaveWord (parmNm) ;
               DupTest (parmNm) ;
               DropC (NewSym (parmNm, KVar, TNone, 0, 0, 0, 0, TRUE)) ;
               IF NOT MatchDelim (',') THEN
                  EXIT
               END
            END ;
            ExpectDelim (':', ENoSemi) ;   (* formal is 'name : type' *)
            ParseType (cls, size, elem) ;
            IF size > 2 THEN
               Err (ENoLib) ;
               RETURN
            END ;
            i := first ;
            WHILE i < symTop DO
               symtab [i].cls := cls ; symtab [i].size := size ;
               symtab [i].elem := elem ;
               symtab [i].off := parmOff ;
               parmOff := parmOff + 2 ;
               INC (i)
            END ;
            IF MatchDelim (')') THEN
               EXIT
            END ;
            IF MatchDelim (';') THEN
               (* next group *)
            ELSIF MatchDelim (',') THEN
               (* the older `name : type, name : type' spelling *)
            ELSE
               Err (ENoSemi) ;
               EXIT
            END
         END
      ELSE
         DropCh (GetCh ())
      END
   END ;
   (* TP3 lays a parameter list out BACKWARDS from BP+4: the LAST declared
      parameter sits at BP+4 and each earlier one is 2 bytes farther from BP
      (RESUME-TP3.md 3.11 - "le dernier paramètre déclaré est le plus proche
      (BP+4)" - and the Code Generation Internals stack frame, "BP+4: last
      parameter").  This is the other half of pushing the arguments as they
      are parsed: the first argument is pushed first and so ends up farthest
      from BP, which has to be the FIRST declared parameter's slot.

      During the loop the offsets were provisional, in declaration order
      (parmOff starts at 4 and grows by 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 - size + 1) MOD 10000H, 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 () ;
   inclActive := FALSE ;
   inclEnd := 0 ;
   (* The image layout is

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

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

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

      dc is put a fixed 4 KiB above the end of the program so that data cannot
      collide with code in a single 64 KiB .COM segment.  LIMITATION: a
      program whose code exceeds 4 KiB overruns its own data area.  TP3 had
      overlay segments for this; we do not, and the check belongs where the
      limit is documented rather than as a silent truncation. *)
   RT_Build (EntSize) ;
   rt := RT_Size () ;
   IF rt >= MaxCode THEN
      Err (EMemOvf) ;                 (* cannot happen: rt is 436 *)
      RETURN
   END ;
   (* The entry jump, at image offset 0.  See the layout note above: a DOS
      .COM is entered at CS:0100, which is file offset 0, so whatever sits
      at offset 0 is the program's first executed instruction. *)
   (* The jump's three bytes are written out longhand rather than through
      Eword, because Eword writes at pc and advances it, and pc is stale at
      this point -- the operand landed wherever the last compile left pc. *)
   cbuf [0] := 0E9H ;                  (* JMP rel16 *)
   entRel := 1 ;
   cbuf [entRel] := 0 ;
   cbuf [entRel + 1] := 0 ;
   i := EntSize ;
   WHILE i - EntSize < rt DO
      cbuf [i] := RT_Byte (i - EntSize) ;
      INC (i)
   END ;
   pc := rt + EntSize ;
   rtSz := rt + EntSize ;
   dataBase := rtSz + 1000H ;
   dc := dataBase ;
   imgReady := TRUE ;
   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 := 0FFFFH ;
   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 *)
   TU_WrStr    := RT_Entry (15) ;      (* a string variable is written through
                                          the address on the stack *)
   TU_RdStr    := RT_Entry (16) ;      (* readln(s)/read(s): TPSRC8 prdstr,
                                          TPSRC4 xrdstr *)
   TU_StrStore := RT_Entry (17) ;      (* s := t: TPSRC8 asnvar, TPSRC2 strstore *)
   TU_CmpStr   := RT_Entry (18) ;      (* string compare: TPSRC9 vcompare,
                                          TPSRC2 cmpstr *)
   TU_StrCat   := RT_Entry (19) ;      (* string concatenation: TPSRC2 xconcat *)
END Inittur ;

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

PROCEDURE Compile (VAR errNo, errPos : CARDINAL) : BOOLEAN ;
VAR tok : CARDINAL ;
    overProc : CARDINAL ;
    hasProc : BOOLEAN ;
BEGIN
   Inittur () ;
   IF OK () THEN
      (* Resolve every {$I} first: the parser (and DeclaresProc's lookahead)
         must see one finished buffer.  See ExpandIncludes. *)
      ExpandIncludes ()
   END ;
   IF OK () THEN
      (* program prologue: header words, CALL initmem, MOV BP,SP *)
      HeadWord (hdrFlag) ;
      HeadWord (hdrCS) ;
      HeadWord (hdrDS) ;
      HeadWord (hdrHeap) ;
      HeadWord (hdrMax) ;
      Eword (16) ;                  (* max open files *)
      Eword (0) ;                   (* input buffer word *)
      Eword (0) ;                   (* output buffer word *)
      (* Here, and not one line earlier, is the first instruction of the
         program: everything above is the header, which is DATA.  The entry
         jump has to land exactly here.  Recorded rather than assumed, so that
         a header that grows a word moves the target with it. *)
      prologAt := pc ;
      (* TU_InitMem takes the header offset in AX, not on the stack, so the
         AX load has to precede the call.  Previously the prologue called
         offset 8 - which in this layout is the hdrMax word - and that was
         coherent only because the runtime was not there.  Now it is the
         real header. *)
      EmMovAxi ((rtSz + LoadBias) MOD 10000H) ;
      DropC (EmCall (TU_InitMem)) ;
      EmMovBpSp () ;
      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.