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.3): 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.  Real/set/record/file and string runtime
   raise Err (ENoLib) pending the future runtime library - matching the
   original's "not implemented" error path. *)

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 ;

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

   (* 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 *)
      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 ;
   rel := (target + 10000H - pc) 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) MOD 10000H ;
   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) MOD 10000H ;
   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 () ;
BEGIN
   Ebyte (8BH) ; Ebyte (04H)
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 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 ;
BEGIN
   Skip () ;
   IF CurCh () = '(' THEN
      DropCh (GetCh ()) ;
      ParseExpr (r) ;
      ExpectDelim (')', ENoSemi) ;
      RETURN
   END ;
   IF (CurCh () = '$') OR (Digit (CurCh ())) OR (ORD (CurCh ()) = AposC) THEN
      RdConst (r.imm, r.cls, 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 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 = 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 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)) ;
   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 ;

END Compiler.