TP3/shell/CompilerLex.mod

IMPLEMENTATION MODULE CompilerLex ;

(* Lexical layer: keyword table, whitespace/comment/directive skipping,
   lookahead, delimiters, numeric/character constants and the string-literal
   pool.  The parser owns the grammar; this module owns the characters. *)

FROM CompilerShared IMPORT MaxName, EUnknown, ECompOvf, AposC, srcPos, abortFac, Err,
                          TString, TReal,
                          TScalar, TBool, KConst, dirs,
                          TkNone, TkProgram, TkBegin, TkEnd, TkIf, TkThen,
                          TkElse, TkWhile, TkDo, TkRepeat, TkUntil, TkFor,
                          TkTo, TkDownto, TkCase, TkOf, TkGoto, TkExit,
                          TkWith, TkVar, TkConst, TkType, TkLabel, TkProcedure,
                          TkFunction, TkNil, TkAnd, TkOr, TkNot, TkDiv,
                          TkMod, TkIn, TkFile, TkText, TkRecord, TkArray,
                          TkSet, TkPacked, TkForward, TkExternal, TkAbsolute,
                          TkOverlay, TkString ;
FROM CompilerSource IMPORT CurCh, GetCh, PeekAhead, Upper, srcLen ;
FROM CompilerUtil IMPORT Digit, Alpha, AlphaNum, IsHexCh, DropCh, NameEq ;
FROM CompilerSymbols IMPORT symtab, wrd, Search ;
VAR
   kName : ARRAY [0..42] OF ARRAY [0..15] OF CHAR ;
   kTk   : ARRAY [0..42] OF CARDINAL ;

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

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

PROCEDURE Skip () ;
(* blanks, comments { } and (* *), compiler directives {$ } / (*$ *)
   letter + sign toggles rng/chk.  Include directives are already gone by the
   time Skip runs: ExpandIncludes splices them into the buffer first, so the
   {$I file} spelling never reaches here.  {$I+}/{$I-} still do, and stay the
   I/O-check toggle, exactly as TPSRC10 cdirec splits them on the sign. *)
VAR ch : CHAR ;
    letter : CHAR ;
BEGIN
   WHILE NOT abortFac DO
      WHILE IsBlank (CurCh ()) DO
         ch := GetCh ()
      END ;
      IF CurCh () = '{' THEN
         ch := GetCh () ;
         IF CurCh () = '$' THEN
            ch := GetCh () ;
            letter := Upper (GetCh ()) ;
            IF CurCh () = '+' THEN
               ch := GetCh () ;
               IF letter = 'I' THEN dirs.chk := TRUE END ;
               IF letter = 'R' THEN dirs.rng := TRUE END
            ELSIF CurCh () = '-' THEN
               ch := GetCh () ;
               IF letter = 'I' THEN dirs.chk := FALSE END ;
               IF letter = 'R' THEN dirs.rng := FALSE END
            END
         END ;
         WHILE (CurCh () # '}') AND (CurCh () # 0C) DO
            ch := GetCh ()
         END ;
         IF CurCh () = '}' THEN
            ch := GetCh ()
         END
      ELSIF (CurCh () = '(') AND (PeekAhead (1) = '*') THEN
         ch := GetCh () ;
         ch := GetCh () ;
         IF CurCh () = '$' THEN
            ch := GetCh () ;
            letter := Upper (GetCh ()) ;
            IF CurCh () = '+' THEN
               ch := GetCh () ;
               IF letter = 'I' THEN dirs.chk := TRUE END ;
               IF letter = 'R' THEN dirs.rng := TRUE END
            ELSIF CurCh () = '-' THEN
               ch := GetCh () ;
               IF letter = 'I' THEN dirs.chk := FALSE END ;
               IF letter = 'R' THEN dirs.rng := FALSE END
            END
         END ;
         LOOP
            IF (CurCh () = '*') AND (PeekAhead (1) = ')') THEN
               ch := GetCh () ;
               ch := GetCh () ;
               EXIT
            END ;
            IF CurCh () = 0C THEN
               EXIT
            END ;
            ch := GetCh ()
         END
      ELSE
         RETURN
      END
   END
END Skip ;

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

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

PROCEDURE DeclaresProc () : BOOLEAN ;
(* Does the REST of the source declare a PROCEDURE or a FUNCTION?

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

PROCEDURE RdConst (VAR v : LONGINT ; VAR cls : CARDINAL ;
                   VAR isStr : BOOLEAN) ;
(* scalar or string constant.  A string literal's text is collected into the
   pool and its slot index left in rdStrX; a single-character literal stays a
   TScalar holding its character code, which is what "c := 'a'" wants. *)
CONST q = AposC ;
VAR ch : CHAR ;
    idx : CARDINAL ;
BEGIN
   isStr := FALSE ;
   cls := TScalar ;
   v := 0 ;
   Skip () ;
   IF CurCh () = '-' THEN
      (* Signed ordinal constant, needed for array bounds such as
         `array[-17..42] of real'.  ParseExpr already handles unary minus in
         expressions; RdConst is the constant-only path and had no sign. *)
      DropCh (GetCh ()) ;
      RdConst (v, cls, isStr) ;
      IF NOT isStr THEN
         v := 0 - v
      END ;
      RETURN
   END ;
   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 CurCh () = '^' THEN
      (* TP3 caret character constant, unquoted: ^M is CR (13), ^[ is ESC
         (27), ^@ is 0.  The value is the upper-cased character minus 64, so
         the +256-MOD-256 keeps ^@ and any control character from wrapping. *)
      DropCh (GetCh ()) ;
      IF CurCh () = 0C THEN
         Err (EUnknown)
      ELSE
         ch := Upper (GetCh ()) ;
         v := VAL (LONGINT, (ORD (ch) + 256 - 64) MOD 256) ;
         cls := TScalar
      END
   ELSIF CurCh () = '#' THEN
      (* TP3 decimal character constant: #27, #255. *)
      DropCh (GetCh ()) ;
      IF Digit (CurCh ()) THEN
         RdIntConst (v) ;
         cls := TScalar
      ELSE
         Err (EUnknown)
      END
   ELSIF Alpha (CurCh ()) THEN
      (* TRUE / FALSE, or a NAMED constant - an enumerator (`[Constant,
         Formula]'), or any earlier const.  A constant expression may name a
         constant, and set literals and `case' labels are full of enumerators. *)
      GetWord () ;
      IF NameEq (wrd, "TRUE") THEN
         v := 1 ;
         cls := TBool
      ELSIF NameEq (wrd, "FALSE") THEN
         v := 0 ;
         cls := TBool
      ELSIF Search (wrd, idx) AND (symtab [idx].tag = KConst) THEN
         v := symtab [idx].lval ;
         cls := symtab [idx].cls
      ELSE
         Err (EUnknown)
      END
   ELSIF ORD (CurCh ()) = q THEN
      DropCh (GetCh ()) ;
      IF ORD (CurCh ()) = q THEN
         (* '' - the empty string.  It used to be reported as the scalar 39,
            so writeln('') printed a single quote mark.  It is a string of
            length zero, and an inline zero-length literal is exactly what the
            runtime's JCXZ path is for. *)
         DropCh (GetCh ()) ;
         isStr := TRUE ;
         cls := TString ;
         v := 0 ;
         rdStrX := StrNew (0, FALSE)
      ELSIF (CurCh () = 0C) OR ((ORD (CurCh ()) = 0DH)) OR ((ORD (CurCh ()) = 0AH)) THEN
         Err (EUnknown)
      ELSE
         v := VAL (LONGINT, ORD (GetCh ())) ;
         cls := TScalar ;
         IF ORD (CurCh ()) = q THEN
            DropCh (GetCh ())
         ELSE
            isStr := TRUE ;
            cls := TString ;
            (* Scan to the closing quote.  NB: the loop condition must test
               the CURRENT character and only the current character.  The
               obvious-looking "while CurCh # quote" with a
               "if PeekAhead(1) = quote then consume two" body is wrong:
               consuming the quote moves the cursor past it, so the next
               condition test sees the character AFTER the literal, is
               satisfied, and the scan runs on to end-of-buffer - which
               silently eats the rest of the program and makes every later
               error point at end-of-file.  Stop on the quote itself, and
               treat a doubled quote as one embedded quote character.

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

END CompilerLex.