|
|
@@ -64,7 +64,18 @@ FROM Runtime IMPORT RT_Build, RT_Size, RT_Byte, RT_Entry, LoadBias ;
|
|
|
operands shift together and the +0100h cancels. *)
|
|
|
|
|
|
FROM CompilerShared IMPORT MaxCode, CodeMax, EUnknown, EMemOvf, ECompOvf,
|
|
|
- EFileNF, EInclNest, OK,
|
|
|
+ EFileNF, EInclNest, OK, AposC,
|
|
|
+ TNone, TArray, TRecord, TSet, TPtr, TFile, TText,
|
|
|
+ TUntyp, TString, TReal, TScalar, TBool, TChar, TEnum,
|
|
|
+ KLabel, KConst, KType, KVar, KProc, KFunc, KBuiltin,
|
|
|
+ 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, dirs,
|
|
|
PatchRec, cbuf, pc, imgReady, patches, nPatch,
|
|
|
srcPos, abortFac, errNum, txerrPos, Err ;
|
|
|
|
|
|
@@ -77,6 +88,11 @@ FROM CompilerUtil IMPORT Digit, Alpha, AlphaNum, IsHexCh, W16, DropCh,
|
|
|
FROM CompilerSymbols IMPORT MaxName, SymEntry, symtab, symTop, lexnest, wrd,
|
|
|
NewSym, Search, DupTest, HideLocals,
|
|
|
CopyWord, SaveWord ;
|
|
|
+FROM CompilerLex IMPORT InitKeys, IsBlank, Skip, GetWord, WddTok,
|
|
|
+ DeclaresProc, KwAhead, PeekKw, MatchKey,
|
|
|
+ MatchDelim, MatchAssign, MatchRange, ExpectDelim,
|
|
|
+ HexVal, RdIntConst, StrNew, StrPut, RdConst,
|
|
|
+ strPool, strOff, strLen, strTop, strCnt, rdStrX ;
|
|
|
|
|
|
(* ---------------------------------------------------------------- *)
|
|
|
(* constants *)
|
|
|
@@ -114,30 +130,6 @@ CONST
|
|
|
and do unbuffered INT 21h I/O, with the data
|
|
|
buffer supplied by the caller. *)
|
|
|
|
|
|
- (* type codes (TP3 vartp) *)
|
|
|
- TNone = 0 ; TArray = 1 ; TRecord = 2 ; TSet = 3 ;
|
|
|
- TPtr = 4 ; TFile = 5 ; TText = 6 ; TUntyp = 7 ;
|
|
|
- TString = 8 ; TReal = 9 ; TScalar = 10 ; TBool = 11 ;
|
|
|
- (* CHAR needs a class of its own. It used to be registered as TScalar,
|
|
|
- which made a CHAR variable indistinguishable from an INTEGER one: the
|
|
|
- class is all IoCall has to dispatch on, so `write(c)` called wrint (the
|
|
|
- value 65 became the *address* 65 and it printed whatever lived at 0x41)
|
|
|
- and `readln(c)` called rdint (which stores a 16-bit result, so it wrote
|
|
|
- two bytes into a one-byte variable). TP3 TPSRC8 prdtyped/pwriteln
|
|
|
- dispatches on the type identifier for exactly this reason. BYTE stays
|
|
|
- TScalar: a BYTE is written as an integer, as in TP3 - but a READ of one
|
|
|
- is dispatched on the variable's size instead (TPSRC8 prdnum
|
|
|
- `CMP varsize,#$01 / JA -> rdint, else rdbyte'), so the one thing class
|
|
|
- alone cannot tell apart is told apart where the size is in hand. *)
|
|
|
- TChar = 12 ;
|
|
|
- TEnum = 13 ; (* an enumeration type: ordinal, size 1 (TP3 uses 1
|
|
|
- byte below 256 values), bounds in SymEntry.lo/hi *)
|
|
|
-
|
|
|
- (* 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 ; BI_Length = 5 ;
|
|
|
@@ -167,19 +159,6 @@ CONST
|
|
|
CrtClr = 0 ; CrtDl = 1 ; CrtDh = 2 ; CrtCaret = 3 ; CrtEol = 4 ;
|
|
|
CrtLow = 5 ; CrtNorm = 6 ; CrtDelay = 7 ; CrtKey = 8 ;
|
|
|
|
|
|
- (* keyword tokens *)
|
|
|
- TkNone = 0 ; TkProgram = 1 ; TkBegin = 2 ; TkEnd = 3 ;
|
|
|
- TkIf = 4 ; TkThen = 5 ; TkElse = 6 ; TkWhile = 7 ;
|
|
|
- TkDo = 8 ; TkRepeat = 9 ; TkUntil = 10 ; TkFor = 11 ;
|
|
|
- TkTo = 12 ; TkDownto = 13 ; TkCase = 14 ; TkOf = 15 ;
|
|
|
- TkGoto = 16 ; TkExit = 17 ; TkWith = 18 ; TkVar = 19 ;
|
|
|
- TkConst= 20 ; TkType = 21 ; TkLabel = 22 ; TkProcedure = 23 ;
|
|
|
- TkFunction = 24 ; TkNil = 25 ; TkAnd = 26 ; TkOr = 27 ;
|
|
|
- TkNot = 28 ; TkDiv = 29 ; TkMod = 30 ; TkIn = 31 ;
|
|
|
- TkFile = 32 ; TkText = 33 ; TkRecord = 34 ; TkArray = 35 ;
|
|
|
- TkSet = 36 ; TkPacked = 37 ; TkForward = 38 ; TkExternal = 39 ;
|
|
|
- TkAbsolute = 40 ; TkOverlay = 41 ; TkString = 42 ;
|
|
|
-
|
|
|
(* Codes for the SYMBOL operators, as BinOpEmit numbers them. The word
|
|
|
operators carry their own Tk* token and need no code here.
|
|
|
These are named, not bare numbers, because every precedence level's
|
|
|
@@ -197,7 +176,6 @@ CONST
|
|
|
EConstRange = 45 ; ENoLib = 102 ; ETypeErr = 56 ;
|
|
|
EIoHere = 66 ; (* I/O not allowed here - TPSRC8 prderrtp *)
|
|
|
|
|
|
- AposC = 39 ; (* ORD ("'") - avoids quote-in-quote *)
|
|
|
|
|
|
(* ---------------------------------------------------------------- *)
|
|
|
(* types *)
|
|
|
@@ -238,8 +216,6 @@ TYPE
|
|
|
hasBounds : BOOLEAN ;
|
|
|
END ;
|
|
|
|
|
|
- DirRec = RECORD rng, chk : BOOLEAN END ;
|
|
|
-
|
|
|
FldRec =
|
|
|
RECORD
|
|
|
name : ARRAY [0..MaxName] OF CHAR ;
|
|
|
@@ -280,22 +256,6 @@ VAR
|
|
|
constBlob : ARRAY [0..511] OF CHAR ; (* bytes of a set/array typed constant
|
|
|
while it is being built *)
|
|
|
|
|
|
- (* String-literal pool.
|
|
|
-
|
|
|
- TP3 does not put a literal in the data segment at all: it emits the
|
|
|
- literal *inline in the code stream* as <length byte><characters>, and
|
|
|
- the runtime entry "wrtinl" reads the length from the return address and
|
|
|
- returns to just past the last character (TPSRC4 xwrtinl, TPSRC10
|
|
|
- estring). So nothing here ends up in the image as data - the pool only
|
|
|
- has to survive from the moment the literal is scanned until IoCall
|
|
|
- decides to emit it, because by then the parser has moved on. *)
|
|
|
- strPool : ARRAY [0..4095] OF CHAR ;
|
|
|
- strOff : ARRAY [0..255] OF CARDINAL ;
|
|
|
- strLen : ARRAY [0..255] OF CARDINAL ;
|
|
|
- strTop : CARDINAL ; (* next free byte in strPool *)
|
|
|
- strCnt : CARDINAL ; (* literals collected so far *)
|
|
|
- rdStrX : CARDINAL ; (* pool index of the literal RdConst just read *)
|
|
|
-
|
|
|
pend : ARRAY [0..MaxPend - 1] OF PendRec ;
|
|
|
nPend : CARDINAL ;
|
|
|
|
|
|
@@ -428,8 +388,6 @@ VAR
|
|
|
order; remapped to TP3's BP+4 rule when the
|
|
|
list has been read (see ProcFunc) *)
|
|
|
|
|
|
- dirs : DirRec ;
|
|
|
-
|
|
|
tmpA, tmpB : CARDINAL ; (* global scratch word addresses *)
|
|
|
crtAttrOff : CARDINAL ; (* image offset of the text attribute byte that
|
|
|
LowVideo/NormVideo set and ClrScr/ClrEol use *)
|
|
|
@@ -916,530 +874,6 @@ END EmRet ;
|
|
|
(* lexer *)
|
|
|
(* ---------------------------------------------------------------- *)
|
|
|
|
|
|
-PROCEDURE InitKeys () ;
|
|
|
-VAR i : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- FOR i := 0 TO 42 DO
|
|
|
- kTk [i] := 0 ;
|
|
|
- kName [i] [0] := 0C
|
|
|
- END ;
|
|
|
- kName [1] := "PROGRAM" ; kTk [1] := TkProgram ;
|
|
|
- kName [2] := "BEGIN" ; kTk [2] := TkBegin ;
|
|
|
- kName [3] := "END" ; kTk [3] := TkEnd ;
|
|
|
- kName [4] := "IF" ; kTk [4] := TkIf ;
|
|
|
- kName [5] := "THEN" ; kTk [5] := TkThen ;
|
|
|
- kName [6] := "ELSE" ; kTk [6] := TkElse ;
|
|
|
- kName [7] := "WHILE" ; kTk [7] := TkWhile ;
|
|
|
- kName [8] := "DO" ; kTk [8] := TkDo ;
|
|
|
- kName [9] := "REPEAT" ; kTk [9] := TkRepeat ;
|
|
|
- kName [10] := "UNTIL" ; kTk [10] := TkUntil ;
|
|
|
- kName [11] := "FOR" ; kTk [11] := TkFor ;
|
|
|
- kName [12] := "TO" ; kTk [12] := TkTo ;
|
|
|
- kName [13] := "DOWNTO" ; kTk [13] := TkDownto ;
|
|
|
- kName [14] := "CASE" ; kTk [14] := TkCase ;
|
|
|
- kName [15] := "OF" ; kTk [15] := TkOf ;
|
|
|
- kName [16] := "GOTO" ; kTk [16] := TkGoto ;
|
|
|
- kName [17] := "EXIT" ; kTk [17] := TkExit ;
|
|
|
- kName [18] := "WITH" ; kTk [18] := TkWith ;
|
|
|
- kName [19] := "VAR" ; kTk [19] := TkVar ;
|
|
|
- kName [20] := "CONST" ; kTk [20] := TkConst ;
|
|
|
- kName [21] := "TYPE" ; kTk [21] := TkType ;
|
|
|
- kName [22] := "LABEL" ; kTk [22] := TkLabel ;
|
|
|
- kName [23] := "PROCEDURE" ; kTk [23] := TkProcedure ;
|
|
|
- kName [24] := "FUNCTION" ; kTk [24] := TkFunction ;
|
|
|
- kName [25] := "NIL" ; kTk [25] := TkNil ;
|
|
|
- kName [26] := "AND" ; kTk [26] := TkAnd ;
|
|
|
- kName [27] := "OR" ; kTk [27] := TkOr ;
|
|
|
- kName [28] := "NOT" ; kTk [28] := TkNot ;
|
|
|
- kName [29] := "DIV" ; kTk [29] := TkDiv ;
|
|
|
- kName [30] := "MOD" ; kTk [30] := TkMod ;
|
|
|
- kName [31] := "IN" ; kTk [31] := TkIn ;
|
|
|
- kName [32] := "FILE" ; kTk [32] := TkFile ;
|
|
|
- kName [33] := "TEXT" ; kTk [33] := TkText ;
|
|
|
- kName [34] := "RECORD" ; kTk [34] := TkRecord ;
|
|
|
- kName [35] := "ARRAY" ; kTk [35] := TkArray ;
|
|
|
- kName [36] := "SET" ; kTk [36] := TkSet ;
|
|
|
- kName [37] := "PACKED" ; kTk [37] := TkPacked ;
|
|
|
- kName [38] := "FORWARD" ; kTk [38] := TkForward ;
|
|
|
- kName [39] := "EXTERNAL" ; kTk [39] := TkExternal ;
|
|
|
- kName [40] := "ABSOLUTE" ; kTk [40] := TkAbsolute ;
|
|
|
- kName [41] := "OVERLAY" ; kTk [41] := TkOverlay ;
|
|
|
- kName [42] := "STRING" ; kTk [42] := TkString
|
|
|
-END InitKeys ;
|
|
|
-
|
|
|
-PROCEDURE IsBlank (ch : CHAR) : BOOLEAN ;
|
|
|
-BEGIN
|
|
|
- RETURN (ch = ' ') OR (ORD (ch) = 09H) OR (ORD (ch) = 0DH) OR (ORD (ch) = 0AH) OR (ORD (ch) = 0CH)
|
|
|
-END IsBlank ;
|
|
|
-
|
|
|
-PROCEDURE Skip () ;
|
|
|
-(* blanks, comments { } and (* *), compiler directives {$ } / (*$ *)
|
|
|
- letter + sign toggles rng/chk. Include directives are already gone by the
|
|
|
- time Skip runs: ExpandIncludes splices them into the buffer first, so the
|
|
|
- {$I file} spelling never reaches here. {$I+}/{$I-} still do, and stay the
|
|
|
- I/O-check toggle, exactly as TPSRC10 cdirec splits them on the sign. *)
|
|
|
-VAR ch : CHAR ;
|
|
|
- letter : CHAR ;
|
|
|
-BEGIN
|
|
|
- WHILE NOT abortFac DO
|
|
|
- WHILE IsBlank (CurCh ()) DO
|
|
|
- ch := GetCh ()
|
|
|
- END ;
|
|
|
- IF CurCh () = '{' THEN
|
|
|
- ch := GetCh () ;
|
|
|
- IF CurCh () = '$' THEN
|
|
|
- ch := GetCh () ;
|
|
|
- letter := Upper (GetCh ()) ;
|
|
|
- IF CurCh () = '+' THEN
|
|
|
- ch := GetCh () ;
|
|
|
- IF letter = 'I' THEN dirs.chk := TRUE END ;
|
|
|
- IF letter = 'R' THEN dirs.rng := TRUE END
|
|
|
- ELSIF CurCh () = '-' THEN
|
|
|
- ch := GetCh () ;
|
|
|
- IF letter = 'I' THEN dirs.chk := FALSE END ;
|
|
|
- IF letter = 'R' THEN dirs.rng := FALSE END
|
|
|
- END
|
|
|
- END ;
|
|
|
- WHILE (CurCh () # '}') AND (CurCh () # 0C) DO
|
|
|
- ch := GetCh ()
|
|
|
- END ;
|
|
|
- IF CurCh () = '}' THEN
|
|
|
- ch := GetCh ()
|
|
|
- END
|
|
|
- ELSIF (CurCh () = '(') AND (PeekAhead (1) = '*') THEN
|
|
|
- ch := GetCh () ;
|
|
|
- ch := GetCh () ;
|
|
|
- IF CurCh () = '$' THEN
|
|
|
- ch := GetCh () ;
|
|
|
- letter := Upper (GetCh ()) ;
|
|
|
- IF CurCh () = '+' THEN
|
|
|
- ch := GetCh () ;
|
|
|
- IF letter = 'I' THEN dirs.chk := TRUE END ;
|
|
|
- IF letter = 'R' THEN dirs.rng := TRUE END
|
|
|
- ELSIF CurCh () = '-' THEN
|
|
|
- ch := GetCh () ;
|
|
|
- IF letter = 'I' THEN dirs.chk := FALSE END ;
|
|
|
- IF letter = 'R' THEN dirs.rng := FALSE END
|
|
|
- END
|
|
|
- END ;
|
|
|
- LOOP
|
|
|
- IF (CurCh () = '*') AND (PeekAhead (1) = ')') THEN
|
|
|
- ch := GetCh () ;
|
|
|
- ch := GetCh () ;
|
|
|
- EXIT
|
|
|
- END ;
|
|
|
- IF CurCh () = 0C THEN
|
|
|
- EXIT
|
|
|
- END ;
|
|
|
- ch := GetCh ()
|
|
|
- END
|
|
|
- ELSE
|
|
|
- RETURN
|
|
|
- END
|
|
|
- END
|
|
|
-END Skip ;
|
|
|
-
|
|
|
-PROCEDURE GetWord () ;
|
|
|
-(* read identifier into wrd (uppercased); next char must be alpha *)
|
|
|
-VAR i : CARDINAL ;
|
|
|
- ch : CHAR ;
|
|
|
-BEGIN
|
|
|
- i := 0 ;
|
|
|
- ch := GetCh () ;
|
|
|
- LOOP
|
|
|
- IF i > MaxName THEN
|
|
|
- wrd [MaxName] := 0C ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- wrd [i] := Upper (ch) ;
|
|
|
- INC (i) ;
|
|
|
- ch := CurCh () ;
|
|
|
- IF NOT AlphaNum (ch) THEN
|
|
|
- wrd [i] := 0C ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ch := GetCh ()
|
|
|
- END
|
|
|
-END GetWord ;
|
|
|
-
|
|
|
-PROCEDURE WddTok () : CARDINAL ;
|
|
|
-(* map wrd -> keyword token *)
|
|
|
-VAR i : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- i := 1 ;
|
|
|
- WHILE i <= 42 DO
|
|
|
- IF kName [i] [0] # 0C THEN
|
|
|
- IF NameEq (wrd, kName [i]) THEN
|
|
|
- RETURN kTk [i]
|
|
|
- END
|
|
|
- END ;
|
|
|
- INC (i)
|
|
|
- END ;
|
|
|
- RETURN TkNone
|
|
|
-END WddTok ;
|
|
|
-
|
|
|
-PROCEDURE DeclaresProc () : BOOLEAN ;
|
|
|
-(* Does the REST of the source declare a PROCEDURE or a FUNCTION?
|
|
|
-
|
|
|
- Needed because the declaration part is compiled BEFORE the main statement
|
|
|
- part, so a procedure's code lands between the program prologue and the
|
|
|
- main body - and nothing jumps over it. A program with a procedure
|
|
|
- therefore ran off the end of the prologue, straight into the first
|
|
|
- procedure, which read its argument out of an uninitialised frame and
|
|
|
- returned to address 0. Every Pascal program containing a procedure was
|
|
|
- broken; `t13_proc` compiled and was never executed, so nothing saw it.
|
|
|
-
|
|
|
- The jump that fixes it has to be emitted BEFORE the declaration part, but
|
|
|
- whether one is needed is only known AFTER - so the only honest options are
|
|
|
- to emit it unconditionally (3 dead bytes in every program, and every code
|
|
|
- size in expected.tsv moves) or to know the answer in advance. This is the
|
|
|
- second: it scans ahead and puts srcPos back.
|
|
|
-
|
|
|
- That is safe because the whole program is already in `src` and `srcPos` is
|
|
|
- a plain index into it - the same trick PeekKw and KwAhead use. The scan
|
|
|
- looks for the keywords anywhere in the remainder rather than tracking the
|
|
|
- nesting of `begin`s, which is deliberately loose: a program with no
|
|
|
- procedures that merely mentions the word in a string literal would get a
|
|
|
- 3-byte jump to the next instruction, which is harmless, whereas tracking
|
|
|
- the main `begin` against a procedure's `begin` would be a second parser
|
|
|
- to get wrong. *)
|
|
|
-VAR save : CARDINAL ;
|
|
|
- found : BOOLEAN ;
|
|
|
- tk : CARDINAL ;
|
|
|
- ch : CHAR ;
|
|
|
-BEGIN
|
|
|
- save := srcPos ;
|
|
|
- found := FALSE ;
|
|
|
- tk := TkNone ; (* so the answer is defined if src is empty *)
|
|
|
- (* Step over delimiters as well as blanks. Stopping at the first
|
|
|
- non-letter looked reasonable and was wrong: `var x : integer ;` is full
|
|
|
- of ':' and ';', so the scan gave up inside the variable section and
|
|
|
- never reached the PROCEDURE. The loop ends at the end of the source,
|
|
|
- not at the first punctuation. *)
|
|
|
- WHILE (NOT found) AND (srcPos < srcLen) DO
|
|
|
- Skip () ;
|
|
|
- IF Alpha (CurCh ()) THEN
|
|
|
- GetWord () ;
|
|
|
- tk := WddTok () ;
|
|
|
- IF (tk = TkProcedure) OR (tk = TkFunction) THEN
|
|
|
- found := TRUE
|
|
|
- END
|
|
|
- ELSE
|
|
|
- ch := GetCh () (* a ':' or ';' - step over it *)
|
|
|
- END
|
|
|
- END ;
|
|
|
- srcPos := save ;
|
|
|
- RETURN (tk = TkProcedure) OR (tk = TkFunction)
|
|
|
-END DeclaresProc ;
|
|
|
-
|
|
|
-PROCEDURE KwAhead (word : ARRAY OF CHAR) : BOOLEAN ;
|
|
|
-(* does the next token (past blanks/comments) equal the keyword 'word',
|
|
|
- without consuming it? srcPos is saved and restored. *)
|
|
|
-VAR save : CARDINAL ;
|
|
|
- k : BOOLEAN ;
|
|
|
-BEGIN
|
|
|
- save := srcPos ;
|
|
|
- Skip () ;
|
|
|
- k := FALSE ;
|
|
|
- IF Alpha (CurCh ()) THEN
|
|
|
- GetWord () ;
|
|
|
- k := NameEq (wrd, word)
|
|
|
- END ;
|
|
|
- srcPos := save ;
|
|
|
- RETURN k
|
|
|
-END KwAhead ;
|
|
|
-
|
|
|
-PROCEDURE PeekKw (VAR tok : CARDINAL) ;
|
|
|
-(* peek at the next keyword token without consuming it *)
|
|
|
-VAR i : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- tok := TkNone ;
|
|
|
- i := 1 ;
|
|
|
- WHILE i <= 42 DO
|
|
|
- IF kName [i] [0] # 0C THEN
|
|
|
- IF KwAhead (kName [i]) THEN
|
|
|
- tok := kTk [i] ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- END ;
|
|
|
- INC (i)
|
|
|
- END
|
|
|
-END PeekKw ;
|
|
|
-
|
|
|
-PROCEDURE MatchKey (VAR tok : CARDINAL) : BOOLEAN ;
|
|
|
-(* skip; if next symbol is a word, read it into wrd and set its token.
|
|
|
- Returns TRUE when a word was read (tok = TkNone for plain ids). *)
|
|
|
-BEGIN
|
|
|
- tok := TkNone ;
|
|
|
- Skip () ;
|
|
|
- IF NOT Alpha (CurCh ()) THEN
|
|
|
- RETURN FALSE
|
|
|
- END ;
|
|
|
- GetWord () ;
|
|
|
- tok := WddTok () ;
|
|
|
- RETURN TRUE
|
|
|
-END MatchKey ;
|
|
|
-
|
|
|
-PROCEDURE MatchDelim (ch : CHAR) : BOOLEAN ;
|
|
|
-BEGIN
|
|
|
- Skip () ;
|
|
|
- IF CurCh () = ch THEN
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- RETURN TRUE
|
|
|
- END ;
|
|
|
- RETURN FALSE
|
|
|
-END MatchDelim ;
|
|
|
-
|
|
|
-PROCEDURE MatchAssign () : BOOLEAN ;
|
|
|
-BEGIN
|
|
|
- Skip () ;
|
|
|
- IF (CurCh () = ':') AND (PeekAhead (1) = '=') THEN
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- RETURN TRUE
|
|
|
- END ;
|
|
|
- RETURN FALSE
|
|
|
-END MatchAssign ;
|
|
|
-
|
|
|
-PROCEDURE MatchRange () : BOOLEAN ;
|
|
|
-BEGIN
|
|
|
- Skip () ;
|
|
|
- IF (CurCh () = '.') AND (PeekAhead (1) = '.') THEN
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- RETURN TRUE
|
|
|
- END ;
|
|
|
- RETURN FALSE
|
|
|
-END MatchRange ;
|
|
|
-
|
|
|
-PROCEDURE ExpectDelim (ch : CHAR ; n : CARDINAL) ;
|
|
|
-BEGIN
|
|
|
- Skip () ;
|
|
|
- IF CurCh () = ch THEN
|
|
|
- DropCh (GetCh ())
|
|
|
- ELSE
|
|
|
- Err (n)
|
|
|
- END
|
|
|
-END ExpectDelim ;
|
|
|
-
|
|
|
-PROCEDURE HexVal (ch : CHAR) : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- IF (ch >= '0') AND (ch <= '9') THEN
|
|
|
- RETURN ORD (ch) - ORD ('0')
|
|
|
- ELSIF (ch >= 'A') AND (ch <= 'F') THEN
|
|
|
- RETURN ORD (ch) - ORD ('A') + 10
|
|
|
- END ;
|
|
|
- RETURN ORD (ch) - ORD ('a') + 10
|
|
|
-END HexVal ;
|
|
|
-
|
|
|
-PROCEDURE RdIntConst (VAR v : LONGINT) ;
|
|
|
-(* bare integer constant; current char is digit or '$' *)
|
|
|
-VAR acc : LONGINT ;
|
|
|
-BEGIN
|
|
|
- acc := 0 ;
|
|
|
- IF CurCh () = '$' THEN
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- WHILE IsHexCh (CurCh ()) DO
|
|
|
- acc := acc * 16 + VAL (LONGINT, HexVal (CurCh ())) ;
|
|
|
- DropCh (GetCh ())
|
|
|
- END
|
|
|
- ELSE
|
|
|
- WHILE Digit (CurCh ()) DO
|
|
|
- acc := acc * 10 + VAL (LONGINT, ORD (CurCh ()) - ORD ('0')) ;
|
|
|
- DropCh (GetCh ())
|
|
|
- END
|
|
|
- END ;
|
|
|
- v := acc
|
|
|
-END RdIntConst ;
|
|
|
-
|
|
|
-PROCEDURE StrNew (first : CARDINAL ; hasFirst : BOOLEAN ) : CARDINAL ;
|
|
|
-(* Open a pool slot for a string literal, optionally pre-seeded with its
|
|
|
- first character.
|
|
|
-
|
|
|
- RdConst has to read the first character before it can tell a one-character
|
|
|
- literal from a longer one - the "is the next character another quote?"
|
|
|
- test only makes sense once something has been read - so the seeding has to
|
|
|
- happen here and has to advance strTop. Leaving strTop alone and letting the
|
|
|
- caller write the character by hand is a trap: strTop is the next FREE byte,
|
|
|
- so the first StrPut lands on top of the seeded character and overwrites it.
|
|
|
- (That bug shipped the literal 'hi' as 69 00 - 'i' then NUL.) *)
|
|
|
-VAR x : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- IF strCnt > HIGH (strOff) THEN
|
|
|
- Err (ECompOvf) ; (* too many literals in one unit *)
|
|
|
- RETURN 0
|
|
|
- END ;
|
|
|
- x := strCnt ;
|
|
|
- strOff [x] := strTop ;
|
|
|
- strLen [x] := 0 ;
|
|
|
- INC (strCnt) ;
|
|
|
- IF hasFirst THEN
|
|
|
- strPool [strTop] := CHR (first) ;
|
|
|
- INC (strTop) ;
|
|
|
- strLen [x] := 1
|
|
|
- END ;
|
|
|
- rdStrX := x ;
|
|
|
- RETURN x
|
|
|
-END StrNew ;
|
|
|
-
|
|
|
-PROCEDURE StrPut (x : CARDINAL ) ;
|
|
|
-(* append the current source character to pool slot x *)
|
|
|
-BEGIN
|
|
|
- IF x > HIGH (strOff) THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF strTop > HIGH (strPool) THEN
|
|
|
- Err (ECompOvf) ; (* literal longer than the pool *)
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- strPool [strTop] := CurCh () ;
|
|
|
- INC (strTop) ;
|
|
|
- INC (strLen [x])
|
|
|
-END StrPut ;
|
|
|
-
|
|
|
-PROCEDURE RdConst (VAR v : LONGINT ; VAR cls : CARDINAL ;
|
|
|
- VAR isStr : BOOLEAN) ;
|
|
|
-(* scalar or string constant. A string literal's text is collected into the
|
|
|
- pool and its slot index left in rdStrX; a single-character literal stays a
|
|
|
- TScalar holding its character code, which is what "c := 'a'" wants. *)
|
|
|
-CONST q = AposC ;
|
|
|
-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 ;
|
|
|
-
|
|
|
(* ---------------------------------------------------------------- *)
|
|
|
(* forward declarations *)
|
|
|
(* ---------------------------------------------------------------- *)
|
