IMPLEMENTATION MODULE Compiler ;

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

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

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

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

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

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

FROM TextBuf IMPORT Length, CharAt ;

FROM SYSTEM IMPORT BYTE ;

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

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

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

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

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

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

   (* runtime entry offsets in the emitted image (TU_InitMem etc.) *)
   TU_InitMem  = 8H ;
   TU_ProgEnd  = 10H ;
   TU_StackChk = 18H ;

   (* Standard-procedure runtime 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_WrInt    = 20H ;  TU_WrChar   = 28H ;  TU_WrBool   = 30H ;
   TU_WrReal   = 38H ;  TU_WrLn     = 40H ;
   TU_RdInt    = 48H ;  TU_RdChar   = 50H ;  TU_RdBool   = 58H ;
   TU_RdLn     = 60H ;  TU_Halt     = 68H ;

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

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

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

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

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

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

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

   DirRec = RECORD  rng, chk : BOOLEAN  END ;

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

VAR
   srcPos, srcLen : CARDINAL ;

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

   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 ;

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

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

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

   dirs     : DirRec ;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(* 1-byte const emitters *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

PROCEDURE EmLoadVar (local : BOOLEAN ; off, nbytes : CARDINAL) ;
VAR disp : CARDINAL ;
BEGIN
   disp := off MOD 100H ;
   IF nbytes = 1 THEN
      IF local THEN
         Ebyte (8AH) ; Ebyte (46H) ; Ebyte (VAL (BYTE, disp))
      ELSE
         Ebyte (0A0H) ; Eword (off)
      END
   ELSE
      IF local THEN
         Ebyte (8BH) ; Ebyte (46H) ; Ebyte (VAL (BYTE, disp))
      ELSE
         Ebyte (0A1H) ; Eword (off)
      END
   END
END EmLoadVar ;

PROCEDURE EmStoreVar (local : BOOLEAN ; off, nbytes : CARDINAL) ;
VAR disp : CARDINAL ;
BEGIN
   disp := off MOD 100H ;
   IF nbytes = 1 THEN
      IF local THEN
         Ebyte (88H) ; Ebyte (46H) ; Ebyte (VAL (BYTE, disp))
      ELSE
         Ebyte (0A2H) ; Eword (off)
      END
   ELSE
      IF local THEN
         Ebyte (89H) ; Ebyte (46H) ; Ebyte (VAL (BYTE, disp))
      ELSE
         Ebyte (0A3H) ; Eword (off)
      END
   END
END EmStoreVar ;

PROCEDURE EmPushVarAddr (local : BOOLEAN ; off : CARDINAL) ;
(* LEA AX,[BP+disp] / LEA AX,[off] then PUSH AX - READ passes the address of
   a variable, not its value.  8D 46 disp is LEA AX,[BP+disp] and 8D 06 off
   is LEA AX,[off] (mod=00 rm=110 = direct disp16), both 8086-legal. *)
VAR disp : CARDINAL ;
BEGIN
   disp := off MOD 100H ;
   IF local THEN
      Ebyte (8DH) ; Ebyte (46H) ; Ebyte (VAL (BYTE, disp))
   ELSE
      Ebyte (8DH) ; Ebyte (06H) ; Eword (off)
   END ;
   EmPushAx ()
END EmPushVarAddr ;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

PROCEDURE RdConst (VAR v : LONGINT ; VAR cls : CARDINAL ;
                   VAR isStr : BOOLEAN) ;
(* scalar or string constant.  String values (isStr) can only be
   rejected with ENoLib by the caller. *)
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
         DropCh (GetCh ()) ;
         v := VAL (LONGINT, q) ;
         cls := TScalar
      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 ;
            WHILE (ORD (CurCh ()) # q) AND (CurCh () # 0C) DO
               IF ORD (PeekAhead (1)) = q THEN
                  DropCh (GetCh ()) ; DropCh (GetCh ())
               ELSE
                  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) *)
BEGIN
   IF r.kind = 0 THEN
      EmMovAxi (W16 (r.imm)) ;
      r.kind := 2
   ELSIF r.kind = 1 THEN
      IF symtab [r.idx].size > 2 THEN
         Err (ENoLib)
      ELSE
         EmLoadVar (symtab [r.idx].local,
                    (symtab [r.idx].off + r.boff) MOD 10000H,
                    symtab [r.idx].size) ;
         IF symtab [r.idx].size = 1 THEN
            EmMovAh0 ()
         END ;
         r.kind := 2
      END
   END
END LoadAtom ;

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

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

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

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

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

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

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

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

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

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

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

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

PROCEDURE ParseAtom (VAR r : ERes) ;
(* const | variable | func(params) | '(' expr ')' *)
VAR idx : CARDINAL ;
    strf : BOOLEAN ;
    quoted : BOOLEAN ;
BEGIN
   r.chr := FALSE ;            (* default: not a quoted char literal *)
   Skip () ;
   IF CurCh () = '(' THEN
      DropCh (GetCh ()) ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      RETURN
   END ;
   IF (CurCh () = '$') OR (Digit (CurCh ())) OR (ORD (CurCh ()) = AposC) THEN
      (* remember that this was a quoted literal BEFORE RdConst consumes it:
         RdConst reports a 1-character literal as TScalar (its char code),
         which is right for "c := 'a'" but would make writeln('a') print 97.
         Mark it so the writer picks the char entry, not the integer one. *)
      quoted := (ORD (CurCh ()) = AposC) ;
      RdConst (r.imm, r.cls, strf) ;
      r.chr := quoted AND (r.cls = TScalar) AND NOT strf ;
      IF r.cls = TReal THEN
         Err (ENoLib) ;
         r.kind := 2 ;
         RETURN
      END ;
      IF strf THEN
         Err (ENoLib) ;
         r.kind := 2 ;
         RETURN
      END ;
      r.kind := 0 ;
      RETURN
   END ;
   IF NOT Alpha (CurCh ()) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   GetWord () ;
   IF NOT Search (wrd, idx) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   IF symtab [idx].tag = KConst THEN
      r.kind := 0 ;
      r.imm := symtab [idx].lval ;
      r.cls := symtab [idx].cls ;
      RETURN
   ELSIF symtab [idx].tag = KFunc THEN
      ParseCall (idx) ;
      r.kind := 2 ;
      r.cls := symtab [idx].cls ;
      RETURN
   ELSIF (symtab [idx].tag = KVar) OR (symtab [idx].tag = KType) THEN
      ParseVar (r) ;
      r.boff := 0 ;
      RETURN
   ELSE
      Err (EUnknown)
   END
END ParseAtom ;

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

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

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

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

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

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

PROCEDURE ParseLabelStmt () ;
(* numeric label definition 'n :' *)
VAR n : CARDINAL ;
    nm : ARRAY [0..9] OF CHAR ;
    idx : CARDINAL ;
    i : CARDINAL ;
BEGIN
   n := 0 ;
   WHILE Digit (CurCh ()) DO
      n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ;
      DropCh (GetCh ())
   END ;
   ExpectDelim (':', ENoSemi) ;
   NumToName (n, nm) ;
   IF Search (nm, idx) THEN
      IF symtab [idx].tag = KLabel THEN
         symtab [idx].defnd := TRUE ;
         symtab [idx].goPos := pc ;
         i := 0 ;
         WHILE i < nPend DO
            IF (pend [i].kind = 0) AND (pend [i].who = idx) THEN
               SetPatTgt (pend [i].place, pc) ;
               pend [i].kind := 99
            END ;
            INC (i)
         END
      ELSE
         Err (EUnknown)
      END
   ELSE
      idx := NewSym (nm, KLabel, TScalar, 0, 0, 0, 0, FALSE) ;
      symtab [idx].defnd := TRUE ;
      symtab [idx].goPos := pc
   END
END ParseLabelStmt ;

PROCEDURE Assignment (r : ERes) ;
(* ':=' already consumed by the caller; store expression into r *)
VAR src : ERes ;
BEGIN
   IF r.kind # 1 THEN
      Err (EUnknown) ;
      RETURN
   END ;
   IF symtab [r.idx].size > 2 THEN
      Err (ENoLib) ;
      RETURN
   END ;
   ParseExpr (src) ;
   LoadAtom (src) ;
   EmStoreVar (symtab [r.idx].local,
               (symtab [r.idx].off + r.boff) MOD 10000H,
               symtab [r.idx].size)
END Assignment ;

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

PROCEDURE IoCall (idx : CARDINAL) ;
(* WRITE / WRITELN / READ / READLN / HALT.

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

   WRITE/WRITELN push the value; READ/READLN push the address, so the
   runtime can store.  As everywhere else in this compiler the caller
   cleans the argument off the stack. *)
VAR args : ARRAY [0..15] OF ERes ;
    nArgs, i, ent, which, acls : CARDINAL ;
    reading : BOOLEAN ;
    dummy : ERes ;
BEGIN
   which := symtab [idx].cls ;               (* BI_* *)
   IF which = BI_Halt THEN
      IF MatchDelim ('(') THEN               (* halt(0) - code ignored *)
         ParseExpr (dummy) ;
         ExpectDelim (')', ENoSemi)
      END ;
      DropC (EmCall (TU_Halt)) ;
      RETURN
   END ;
   reading := (which = BI_Read) OR (which = BI_ReadLn) ;
   nArgs := 0 ;
   IF MatchDelim ('(') THEN
      IF CurCh () # ')' THEN
         LOOP
            IF nArgs >= 16 THEN
               Err (ECompOvf) ;
               EXIT
            END ;
            ParseExpr (args [nArgs]) ;
            INC (nArgs) ;
            IF NOT MatchDelim (',') THEN
               EXIT
            END
         END ;
         IF NOT MatchDelim (')') THEN
            Err (ENoSemi) ;
            RETURN
         END
      ELSE
         DropCh (GetCh ())
      END
   END ;
   IF reading AND (nArgs = 0) THEN
      (* readln with no variable: just skip to the next line *)
      DropC (EmCall (TU_RdLn)) ;
      RETURN
   END ;
   (* NB: guard the loop bound - with nArgs = 0, "nArgs - 1" would wrap round
      to 65535 in CARDINAL and spin 65536 times. *)
   IF nArgs > 0 THEN
      FOR i := 0 TO nArgs - 1 DO
      IF reading THEN
         IF args [i].kind # 1 THEN
            Err (ETypeErr) ;                  (* READ needs a variable *)
            RETURN
         END ;
         acls := symtab [args [i].idx].cls ;
         IF acls = TString THEN
            Err (ENoLib) ;                    (* string runtime pending *)
            RETURN
         END ;
         EmPushVarAddr (symtab [args [i].idx].local, symtab [args [i].idx].off) ;
         IF acls = TReal THEN
            ent := TU_RdInt                   (* real reads: not yet *)
         ELSIF acls = TBool THEN
            ent := TU_RdBool
         ELSIF acls = TScalar THEN
            ent := TU_RdInt
         ELSE
            ent := TU_RdChar
         END
      ELSE
         acls := args [i].cls ;
         IF acls = TString THEN
            Err (ENoLib) ;                    (* string runtime pending *)
            RETURN
         END ;
         LoadAtom (args [i]) ;
         EmPushAx () ;
         IF args [i].chr THEN
            ent := TU_WrChar                   (* 'a' - one char, not 97 *)
         ELSIF acls = TReal THEN
            ent := TU_WrReal
         ELSIF acls = TBool THEN
            ent := TU_WrBool
         ELSIF acls = TScalar THEN
            ent := TU_WrInt
         ELSE
            ent := TU_WrChar
         END
      END ;
      DropC (EmCall (ent)) ;
      EmAddSp (2)                            (* one 16-bit argument *)
      END
   END ;
   IF which = BI_WriteLn THEN
      DropC (EmCall (TU_WrLn))
   ELSIF which = BI_ReadLn THEN
      DropC (EmCall (TU_RdLn))
   END
END IoCall ;

PROCEDURE Statmnt () ;
VAR tok : CARDINAL ;
    idx, i2 : CARDINAL ;
    t, src : ERes ;
    L1, zj, zj2, exj : CARDINAL ;
    lo, hi, v : LONGINT ;
    clso : CARDINAL ;
    i : CARDINAL ;
    nm : ARRAY [0..MaxName] OF CHAR ;
    strf : BOOLEAN ;
    dow : BOOLEAN ;
BEGIN
   Skip () ;
   IF Digit (CurCh ()) THEN
      ParseLabelStmt () ;      (* consumed 'n' ':' *)
      Statmnt () ;             (* 'n : statement' - the statement follows
                                  the label directly, with no ';' between *)
      RETURN
   END ;
   IF NOT Alpha (CurCh ()) THEN
      ExpectDelim (';', ENoSemi) ;
      RETURN
   END ;
   DropB (MatchKey (tok)) ;
   IF tok = TkBegin THEN
      Compound ()
   ELSIF tok = TkIf THEN
      ParseExpr (t) ;
      LoadAtom (t) ;
      EmCmpAxi (0) ;
      zj := EmJcc (84H, 0) ;          (* JZ -> else/end *)
      IF NOT (MatchKey (tok) AND (tok = TkThen)) THEN
         Err (ENoSemi)
      END ;
      Statmnt () ;
      IF MatchKey (tok) AND (tok = TkElse) THEN
         exj := EmJmpNear (0) ;
         SetPatTgt (zj, pc) ;
         Statmnt () ;
         SetPatTgt (exj, pc)
      ELSE
         SetPatTgt (zj, pc)
      END
   ELSIF tok = TkWhile THEN
      L1 := pc ;
      ParseExpr (t) ;
      LoadAtom (t) ;
      EmCmpAxi (0) ;
      zj := EmJcc (84H, 0) ;          (* JZ -> end *)
      IF NOT (MatchKey (tok) AND (tok = TkDo)) THEN
         Err (ENoSemi)
      END ;
      brkSave [brkN] := exitCnt ;
      loopTy [brkN] := 1 ;
      INC (brkN) ;
      Statmnt () ;
      DEC (brkN) ;
      i := brkSave [brkN] ;
      WHILE i < exitCnt DO
         SetPatTgt (exitPatch [i], pc) ;
         INC (i)
      END ;
      exitCnt := brkSave [brkN] ;
      DropC (EmJmpNear (L1)) ;
      SetPatTgt (zj, pc)
   ELSIF tok = TkRepeat THEN
      L1 := pc ;
      brkSave [brkN] := exitCnt ;
      loopTy [brkN] := 1 ;
      INC (brkN) ;
      Statmnt () ;
      IF NOT (MatchKey (tok) AND (tok = TkUntil)) THEN
         Err (ENoSemi)
      END ;
      ParseExpr (t) ;
      LoadAtom (t) ;
      EmCmpAxi (0) ;
      zj := EmJcc (85H, L1) ;         (* JNZ -> body again *)
      DEC (brkN) ;
      i := brkSave [brkN] ;
      WHILE i < exitCnt DO
         SetPatTgt (exitPatch [i], pc) ;
         INC (i)
      END ;
      exitCnt := brkSave [brkN]
   ELSIF tok = TkFor THEN
      (* control variable *)
      Skip () ;                   (* after the FOR keyword: skip blanks *)
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      GetWord () ;
      IF NOT Search (wrd, idx) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      IF symtab [idx].size > 2 THEN
         Err (ENoLib) ;
         RETURN
      END ;
      IF NOT MatchAssign () THEN
         Err (ENoSemi)
      END ;
      ParseExpr (src) ;
      LoadAtom (src) ;
      EmStoreVar (symtab [idx].local, symtab [idx].off,
                  symtab [idx].size) ;
      IF NOT MatchKey (tok) THEN
         Err (ESimpType) ;
         RETURN
      END ;
      IF (tok = TkTo) OR (tok = TkDownto) THEN
         dow := (tok = TkDownto)
      ELSE
         Err (ESimpType) ;
         RETURN
      END ;
      ParseExpr (t) ;
      LoadAtom (t) ;
      EmPushAx () ;                    (* loop bound on the stack *)
      IF NOT (MatchKey (tok) AND (tok = TkDo)) THEN
         Err (ENoSemi)
      END ;
      brkSave [brkN] := exitCnt ;
      loopTy [brkN] := 2 ;
      INC (brkN) ;
      L1 := pc ;                       (* Ltest *)
      Statmnt () ;
      DEC (brkN) ;
      i := brkSave [brkN] ;
      WHILE i < exitCnt DO
         SetPatTgt (exitPatch [i], pc) ;
         INC (i)
      END ;
      exitCnt := brkSave [brkN] ;
      (* test then step: ax = var ; cx = bound (from [sp]) *)
      EmMovCxSp () ;
      EmLoadVar (symtab [idx].local, symtab [idx].off,
                 symtab [idx].size) ;
      EmCmpAxCx () ;
      IF dow THEN
         zj := EmJcc (8CH, 0)          (* JL -> done *)
      ELSE
         zj := EmJcc (8FH, 0)          (* JG -> done *)
      END ;
      EmLoadVar (symtab [idx].local, symtab [idx].off,
                 symtab [idx].size) ;
      IF dow THEN
         EmDecAx ()
      ELSE
         EmIncAx ()
      END ;
      EmStoreVar (symtab [idx].local, symtab [idx].off,
                  symtab [idx].size) ;
      DropC (EmJmpNear (L1)) ;
      SetPatTgt (zj, pc) ;             (* done: drop bound, continue *)
      EmAddSp (2)
   ELSIF tok = TkCase THEN
      ParseExpr (t) ;
      LoadAtom (t) ;
      EmPushAx () ;                    (* selector on the stack *)
      IF NOT (MatchKey (tok) AND (tok = TkOf)) THEN
         Err (ENoSemi)
      END ;
      caseN := 0 ;
      LOOP
         Skip () ;
         IF MatchDelim (';') THEN
            Skip ()
         END ;
         PeekKw (tok) ;
         IF (tok = TkEnd) OR (tok = TkElse) THEN
            EXIT
         END ;
         (* case label : constant identifier or literal *)
         IF Alpha (CurCh ()) THEN
            GetWord () ;
            IF Search (wrd, i2) AND (symtab [i2].tag = KConst) THEN
               lo := symtab [i2].lval
            ELSE
               Err (EUnknown) ;
               EXIT
            END
         ELSE
            RdConst (lo, clso, strf)
         END ;
         IF MatchRange () THEN
            RdConst (hi, clso, strf)
         ELSE
            hi := lo
         END ;
         ExpectDelim (':', ENoSemi) ;
         EmMovAxSp () ;
         EmCmpAxi (W16 (lo)) ;
         zj := EmJcc (85H, 0) ;        (* JNZ -> next *)
         IF hi # lo THEN
            EmCmpAxi (W16 (hi)) ;
            zj2 := EmJcc (85H, 0)
         ELSE
            zj2 := 0
         END ;
         Statmnt () ;
         IF caseN >= 64 THEN
            Err (ECompOvf) ;
            EXIT
         END ;
         caseJmp [caseN] := EmJmpNear (0) ;
         INC (caseN) ;
         SetPatTgt (zj, pc) ;
         IF zj2 # 0 THEN
            SetPatTgt (zj2, pc)
         END
      END ;
      IF tok = TkElse THEN
         DropB (MatchKey (tok)) ;
         Statmnt () ;
         IF NOT (MatchKey (tok) AND (tok = TkEnd)) THEN
            Err (ENoSemi)
         END
      ELSE
         DropB (MatchKey (tok))
      END ;
      EmAddSp (2) ;
      FOR i := 0 TO caseN - 1 DO
         SetPatTgt (caseJmp [i], pc)
      END
   ELSIF tok = TkGoto THEN
      v := 0 ;
      Skip () ;                  (* after the GOTO keyword: skip blanks *)
      IF Digit (CurCh ()) THEN
         RdIntConst (v) ;
         NumToName (W16 (v), nm) ;
         IF Search (nm, idx) THEN
            IF symtab [idx].tag = KLabel THEN
               IF symtab [idx].defnd THEN
                  DropC (EmJmpNear (symtab [idx].goPos))
               ELSE
                  zj := EmJmpNear (0) ;
                  AddPend (0, idx, zj)
               END
            ELSE
               Err (EUnknown)
            END
         ELSE
            idx := NewSym (nm, KLabel, TScalar, 0, 0, 0, 0, FALSE) ;
            zj := EmJmpNear (0) ;
            AddPend (0, idx, zj)
         END
      ELSE
         Err (EUnknown)
      END
   ELSIF tok = TkExit THEN
      IF brkN = 0 THEN
         Err (EUnknown)
      ELSE
         IF loopTy [brkN - 1] = 2 THEN
            EmAddSp (2)                (* drop FOR bound *)
         END ;
         zj := EmJmpNear (0) ;
         IF exitCnt < 64 THEN
            exitPatch [exitCnt] := zj ;
            INC (exitCnt)
         END
      END
   ELSIF tok = TkWith THEN
      Err (ENoLib)
   ELSE
      (* identifier statement: assignment or call *)
      IF NOT Search (wrd, idx) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      IF symtab [idx].tag = KBuiltin THEN
         IoCall (idx) ;
         RETURN
      END ;
      IF symtab [idx].tag = KProc THEN
         IF MatchDelim ('(') THEN
            ParseCallArgs (idx)
         ELSE
            ParseCall (idx)
         END ;
         RETURN
      END ;
      IF (symtab [idx].tag = KVar) OR (symtab [idx].tag = KFunc) THEN
         t.idx := idx ;
         t.kind := 1 ;
         t.boff := 0 ;
         t.cls := symtab [idx].cls ;
         IF symtab [idx].tag = KFunc THEN
            t.idx := symtab [idx].resvar ;
            t.cls := symtab [t.idx].cls
         END ;
         ParseSub (t) ;
         IF MatchAssign () THEN
            Assignment (t) ;
            RETURN
         END ;
         Err (ENoSemi) ;
         RETURN
      END ;
      Err (ENoSemi)
   END
END Statmnt ;

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

PROCEDURE ParseType (VAR cls, size, elem : CARDINAL) ;
VAR tok : CARDINAL ;
    idx : CARDINAL ;
    lo, hi : LONGINT ;
    s2, e2 : CARDINAL ;
    subcls : CARDINAL ;
    strf : BOOLEAN ;
    consumed : BOOLEAN ;
BEGIN
   cls := TNone ; size := 0 ; elem := 0 ;
   consumed := FALSE ;
   Skip () ;                (* after ':' / '=' : skip blanks *)
   IF Alpha (CurCh ()) THEN
      DropB (MatchKey (tok)) ;
      consumed := TRUE
   ELSE
      tok := TkNone
   END ;
   IF tok = TkArray THEN
      ExpectDelim ('[', ENoSemi) ;
      RdConst (lo, subcls, strf) ;
      IF NOT MatchRange () THEN
         Err (ESimpType)
      END ;
      RdConst (hi, subcls, strf) ;
      ExpectDelim (']', ENoSemi) ;
      IF NOT (MatchKey (tok) AND (tok = TkOf)) THEN
         Err (ENoSemi)
      END ;
      ParseType (cls, s2, e2) ;
      cls := TArray ;
      elem := s2 ;
      size := s2 * (W16 (VAL (LONGINT, W16 (hi))
                          - VAL (LONGINT, W16 (lo)) + 1))
   ELSIF tok = TkString THEN
      cls := TString ;
      size := 256 ;
      elem := 1 ;
      IF MatchDelim ('[') THEN
         RdConst (hi, subcls, strf) ;
         ExpectDelim (']', ENoSemi) ;
         size := W16 (hi) + 1
      END
   ELSIF tok = TkSet THEN
      Err (ENoLib) ;
      IF MatchKey (tok) AND (tok = TkOf) THEN
         ParseType (cls, s2, e2)
      END
   ELSIF tok = TkRecord THEN
      Err (ENoLib) ;
      LOOP
         PeekKw (tok) ;
         IF tok = TkEnd THEN
            DropB (MatchKey (tok)) ;
            EXIT
         END ;
         IF CurCh () = 0C THEN
            EXIT
         END ;
         Skip () ;
         IF Alpha (CurCh ()) THEN
            DropCh (GetCh ())
         ELSE
            DropCh (GetCh ())
         END
      END
   ELSIF (tok = TkFile) OR (tok = TkText) THEN
      cls := TFile ;
      size := 0 ;
      elem := 0 ;
      Err (ENoLib)
   ELSE
      IF consumed THEN
         IF Search (wrd, idx) AND (symtab [idx].tag = KType) THEN
            cls := symtab [idx].cls ;
            size := symtab [idx].size ;
            elem := symtab [idx].size
         ELSE
            Err (EUnknown)
         END
      ELSE
         (* subrange lo .. hi *)
         RdConst (lo, subcls, strf) ;
         IF NOT MatchRange () THEN
            Err (ESimpType) ;
            RETURN
         END ;
         RdConst (hi, subcls, strf) ;
         cls := TScalar ;
         size := 2 ;
         elem := 2
      END
   END
END ParseType ;

PROCEDURE DefVar () ;
(* 'name' (',' name)* ':' type [ABSOLUTE addr] ; group repeated until a
   declaration keyword appears *)
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    cls, size, elem : CARDINAL ;
    tok : CARDINAL ;
    v : LONGINT ;
    off : CARDINAL ;
BEGIN
   LOOP
      Skip () ;                (* after the VAR keyword: skip blanks *)
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      LOOP
         GetWord () ;
         SaveWord (nm) ;
         DupTest (nm) ;
         IF NOT MatchDelim (':') THEN
            Err (ENoSemi)
         END ;
         ParseType (cls, size, elem) ;
         off := 0 ;
         IF lexnest = 0 THEN
            IF size > 2 THEN
               Err (ENoLib) ;
               RETURN
            END ;
            PeekKw (tok) ;
            IF tok = TkAbsolute THEN
               DropB (MatchKey (tok)) ;
               IF (CurCh () = '$') OR (Digit (CurCh ())) THEN
                  RdIntConst (v) ;
                  off := W16 (v)
               ELSE
                  Err (EUnknown)
               END
            ELSE
               off := dc ;
               dc := dc + size
            END ;
            DropC (NewSym (nm, KVar, cls, size, elem, off, 0, FALSE)) ;
            varspc := varspc + size
         ELSE
            IF size > 2 THEN
               Err (ENoLib) ;
               RETURN
            END ;
            DropC (NewSym (nm, KVar, cls, size, elem, locFree, 0, TRUE)) ;
            locFree := (locFree - size) MOD 10000H ;
            locBytes := locBytes + size
         END ;
         IF NOT MatchDelim (',') THEN
            EXIT
         END
      END ;
      IF NOT MatchDelim (';') THEN
         Err (ENoSemi) ;
         RETURN
      END ;
      PeekKw (tok) ;
      IF tok # TkNone THEN
         RETURN
      END
   END
END DefVar ;

PROCEDURE DefConst () ;
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    v : LONGINT ;
    cls : CARDINAL ;
    isStr : BOOLEAN ;
    tok : CARDINAL ;
BEGIN
   LOOP
      PeekKw (tok) ;
      IF tok # TkNone THEN
         RETURN
      END ;
      Skip () ;                (* after the CONST keyword: skip blanks *)
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      GetWord () ;
      SaveWord (nm) ;
      DupTest (nm) ;
      ExpectDelim ('=', ENoSemi) ;
      RdConst (v, cls, isStr) ;
      IF isStr THEN
         Err (ENoLib)
      END ;
      DropC (NewSym (nm, KConst, cls, 0, 0, 0, v, FALSE)) ;
      IF NOT MatchDelim (';') THEN
         Err (ENoSemi) ;
         RETURN
      END
   END
END DefConst ;

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

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

PROCEDURE SymEpi () ;
(* function result: AX := result var *)
BEGIN
   IF curIsFunc THEN
      IF OK () THEN
         EmLoadVar (TRUE, symtab [resultVar].off, symtab [resultVar].size)
      END
   END
END SymEpi ;

PROCEDURE ProcFunc () ;
(* PROCEDURE name (params) ; body | FUNCTION name (params) : type ; body *)
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    idx, old : CARDINAL ;
    tok, tok2 : CARDINAL ;
    parmNm : ARRAY [0..MaxName] OF CHAR ;
    cls, size, elem : CARDINAL ;
    isFunc : BOOLEAN ;
    saveNest, saveLoc, saveRes, saveF : CARDINAL ;
    saveLB, savePO : CARDINAL ;
    i : CARDINAL ;
BEGIN
   isFunc := curIsFunc ;
   Skip () ;                   (* after the PROCEDURE/FUNCTION keyword *)
   IF NOT Alpha (CurCh ()) THEN
      Err (EUnknown) ;
      RETURN
   END ;
   GetWord () ;
   SaveWord (nm) ;
   IF Search (nm, idx) AND (symtab [idx].tag = KProc)
      AND (symtab [idx].fwd) THEN
      old := idx
   ELSIF Search (nm, idx) THEN
      Err (EUnknown) ;
      RETURN
   ELSE
      old := NewSym (nm, KProc, TNone, 0, 0, 0, 0, FALSE)
   END ;
   IF isFunc THEN
      symtab [old].tag := KFunc
   END ;
   saveNest := lexnest ;
   saveLoc := locFree ;
   saveRes := resultVar ;
   saveF := VAL (CARDINAL, ORD (curIsFunc)) ;
   saveLB := locBytes ;
   savePO := parmOff ;
   INC (lexnest) ;
   locFree := 0FFFEH ;
   locBytes := 0 ;
   parmOff := 4 ;
   IF MatchDelim ('(') THEN
      IF CurCh () # ')' THEN
         LOOP
            (* PeekKw, not MatchKey: MatchKey CONSUMES the word it reads, so
               using it to test for VAR would eat the parameter's name. *)
            PeekKw (tok) ;
            IF tok = TkVar THEN
               (* VAR parameter recorded as value in this milestone *)
               DropB (MatchKey (tok))
            END ;
            Skip () ;             (* blanks before the parameter name *)
            IF NOT Alpha (CurCh ()) THEN
               Err (EUnknown) ;
               RETURN
            END ;
            GetWord () ;
            SaveWord (parmNm) ;
            DupTest (parmNm) ;
            ExpectDelim (':', ENoSemi) ;   (* formal is 'name : type' *)
            ParseType (cls, size, elem) ;
            IF size > 2 THEN
               Err (ENoLib) ;
               RETURN
            END ;
            DropC (NewSym (parmNm, KVar, cls, size, elem, parmOff, 0, TRUE)) ;
            parmOff := parmOff + 2 ;
            IF NOT MatchDelim (',') THEN
               IF MatchDelim (')') THEN
                  EXIT
               END ;
               Err (ENoSemi) ;
               EXIT
            END
         END
      ELSE
         DropCh (GetCh ())
      END
   END ;
   IF isFunc THEN
      IF MatchDelim (':') THEN
         ParseType (cls, size, elem)
      ELSE
         cls := TScalar ;
         size := 2 ;
         elem := 2
      END ;
      IF size > 2 THEN
         Err (ENoLib) ;
         RETURN
      END ;
      symtab [old].cls := cls ;
      symtab [old].size := size ;
      resultVar := NewSym (nm, KVar, cls, size, elem, locFree, 0, TRUE) ;
      symtab [old].resvar := resultVar ;
      locFree := (locFree - size) MOD 10000H ;
      locBytes := locBytes + size
   END ;
   IfMatchSemi () ;
   PeekKw (tok2) ;
   IF (tok2 = TkForward) OR (tok2 = TkExternal) THEN
      DropB (MatchKey (tok2)) ;
      symtab [old].fwd := TRUE ;
      symtab [old].defnd := (tok2 = TkExternal) ;
      IfMatchSemi () ;
      lexnest := saveNest ;
      locFree := saveLoc ;
      resultVar := saveRes ;
      curIsFunc := (saveF # 0) ;
      locBytes := saveLB ;
      parmOff := savePO ;
      RETURN
   END ;
   (* body *)
   symtab [old].goPos := pc ;
   symtab [old].defnd := TRUE ;
   EmPushBp () ;
   EmMovBpSp () ;
   DefPart () ;                       (* nested declarations; stops at BEGIN *)
   IF locBytes > 0 THEN
      EmSubSp (locBytes)
   END ;
   DropC (EmCall (TU_StackChk)) ;
   Statmnt () ;                       (* body *)
   IF OK () THEN
      SymEpi () ;
      EmLeave () ;
      EmRet ()
   END ;
   (* patch pending forward calls to this proc *)
   i := 0 ;
   WHILE i < nPend DO
      IF (pend [i].kind = 1) AND (pend [i].who = old) THEN
         SetPatTgt (pend [i].place, symtab [old].goPos) ;
         pend [i].kind := 99
      END ;
      INC (i)
   END ;
   lexnest := saveNest ;
   locFree := saveLoc ;
   resultVar := saveRes ;
   curIsFunc := (saveF # 0) ;
   locBytes := saveLB ;
   parmOff := savePO
END ProcFunc ;

PROCEDURE DefType () ;
(* 'name' '=' typeDef ; ... until a declaration keyword appears *)
VAR nm : ARRAY [0..MaxName] OF CHAR ;
    cls, size, elem : CARDINAL ;
    tok : CARDINAL ;
BEGIN
   LOOP
      PeekKw (tok) ;
      IF tok # TkNone THEN
         RETURN
      END ;
      Skip () ;                (* after the TYPE keyword: skip blanks *)
      IF NOT Alpha (CurCh ()) THEN
         Err (EUnknown) ;
         RETURN
      END ;
      GetWord () ;
      SaveWord (nm) ;
      DupTest (nm) ;
      ExpectDelim ('=', ENoSemi) ;
      ParseType (cls, size, elem) ;
      IF NOT OK () THEN
         RETURN
      END ;
      DropC (NewSym (nm, KType, cls, size, elem, 0, 0, FALSE)) ;
      IF NOT MatchDelim (';') THEN
         Err (ENoSemi) ;
         RETURN
      END
   END
END DefType ;

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

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

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

   Tagged KBuiltin (not KProc) because these are not called generically:
   WRITE/WRITELN/READ/READLN need TP3's per-argument type dispatch
   (IoCall), and HALT takes no argument at all.  defnd is TRUE because the
   entry point is known - there is no forward reference to patch. *)
VAR i : CARDINAL ;
BEGIN
   i := NewSym ("WRITE"  , KBuiltin, BI_Write  , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   symtab [i].goPos := TU_WrInt ;
   i := NewSym ("WRITELN", KBuiltin, BI_WriteLn, 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   symtab [i].goPos := TU_WrInt ;
   i := NewSym ("READ"   , KBuiltin, BI_Read   , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   symtab [i].goPos := TU_RdInt ;
   i := NewSym ("READLN" , KBuiltin, BI_ReadLn , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   symtab [i].goPos := TU_RdInt ;
   i := NewSym ("HALT"   , KBuiltin, BI_Halt   , 0, 0, 0, 0, FALSE) ;
   symtab [i].defnd := TRUE ;
   symtab [i].goPos := TU_Halt
END DefBuiltins ;

PROCEDURE Inittur () ;
(* reset compiler state and define the standard types *)
BEGIN
   abortFac := FALSE ;
   errNum := 0 ;
   txerrPos := 0 ;
   srcPos := 0 ;
   srcLen := Length () ;
   pc := 0 ;
   dc := 100H ;
   varspc := 0 ;
   symTop := 0 ;
   nPatch := 0 ;
   nPend := 0 ;
   exitCnt := 0 ;
   brkN := 0 ;
   caseN := 0 ;
   lexnest := 0 ;
   curIsFunc := FALSE ;
   resultVar := 0 ;
   locFree := 0FFFEH ;
   locBytes := 0 ;
   parmOff := 4 ;
   dirs.rng := TRUE ;
   dirs.chk := TRUE ;
   InitKeys () ;
   DropC (NewSym ("INTEGER", KType, TScalar, 2, 2, 0, 0, FALSE)) ;
   DropC (NewSym ("BYTE"   , KType, TScalar, 1, 1, 0, 0, FALSE)) ;
   DropC (NewSym ("CHAR"   , KType, TScalar, 1, 1, 0, 0, FALSE)) ;
   DropC (NewSym ("BOOLEAN", KType, TBool  , 1, 1, 0, 0, FALSE)) ;
   DropC (NewSym ("REAL"   , KType, TReal  , 6, 6, 0, 0, FALSE)) ;
   DropC (NewSym ("STRING" , KType, TString, 256, 1, 0, 0, FALSE)) ;
   DropC (NewSym ("TRUE"   , KConst, TBool, 1, 1, 0, 1, FALSE)) ;
   DropC (NewSym ("FALSE"  , KConst, TBool, 1, 1, 0, 0, FALSE)) ;
   DefBuiltins () ;
   tmpA := NewSym ("@@T1", KVar, TScalar, 2, 2, dc, 0, FALSE) ;
   dc := dc + 2 ;
   tmpB := NewSym ("@@T2", KVar, TScalar, 2, 2, dc, 0, FALSE) ;
   dc := dc + 2
END Inittur ;

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

PROCEDURE Compile (VAR errNo, errPos : CARDINAL) : BOOLEAN ;
VAR tok : CARDINAL ;
BEGIN
   Inittur () ;
   IF OK () THEN
      (* program prologue: header words, CALL initmem, MOV BP,SP *)
      HeadWord (hdrFlag) ;
      HeadWord (hdrCS) ;
      HeadWord (hdrDS) ;
      HeadWord (hdrHeap) ;
      HeadWord (hdrMax) ;
      Eword (16) ;                  (* max open files *)
      Eword (0) ;                   (* input buffer word *)
      Eword (0) ;                   (* output buffer word *)
      DropC (EmCall (TU_InitMem)) ;
      EmMovBpSp () ;
      IF MatchKey (tok) AND (tok = TkProgram) THEN
         (* MatchKey stops right after "PROGRAM", so the optional program
            name normally follows blanks.  Skip them before testing for the
            name: otherwise Alpha sees the blank, the name is never consumed
            and IfMatchSemi reports ENoSemi at the name. *)
         Skip () ;
         IF Alpha (CurCh ()) THEN
            GetWord ()
         END ;
         IF MatchDelim ('(') THEN
            WHILE NOT MatchDelim (')') DO
               IF Alpha (CurCh ()) THEN
                  GetWord ()
               END ;
               IF CurCh () = ',' THEN
                  DropCh (GetCh ())
               END
            END
         END ;
         IfMatchSemi ()
      END ;
      IF OK () THEN
         DefPart () ;
         IF OK () THEN
            IF MatchKey (tok) AND (tok = TkBegin) THEN
               Compound () ;
               IF OK () THEN
                  EmXorAxAx () ;
                  DropC (EmCall (TU_ProgEnd)) ;
                  ResolvePatches () ;
                  codeSz := pc ;
                  dataSz := dc ;
                  cbuf [hdrCS] := VAL (BYTE, (codeSz DIV 16) MOD 100H) ;
                  cbuf [hdrCS + 1] := VAL (BYTE, ((codeSz DIV 16) DIV 100H) MOD 100H) ;
                  cbuf [hdrDS] := VAL (BYTE, (dataSz DIV 16) MOD 100H) ;
                  cbuf [hdrDS + 1] := VAL (BYTE, ((dataSz DIV 16) DIV 100H) MOD 100H) ;
                  cbuf [hdrFlag] := 1 ;
                  cbuf [hdrFlag + 1] := 0 ;
                  cbuf [hdrHeap] := 0 ;
                  cbuf [hdrHeap + 1] := 0 ;
                  cbuf [hdrMax] := 0 ;
                  cbuf [hdrMax + 1] := 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 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.