IMPLEMENTATION MODULE Compiler ; (* Turbo Pascal 3-style single-pass Pascal -> 8086 compiler in GNU Modula-2 (-fiso), following the structure of the original TPSRC6 'turbo' entry / TPSRC7-10: Inittur reset state, pre-defined types, scratch temporaries Skip lexer: blanks, comments { } and (* *), directives {$ } GetWord/WddTok/MatchKey word lexing with a keyword table (kName/kTk) PeekKw lookahead keyword check WITHOUT consuming (via saved srcPos) - needed because declarations and compound statements peek at END/ELSE/etc RdIntConst/RdConst integer, hex and char constants Search symbol table lookup filtered by lexical level ParseExpr -> ParseCmp -> ParseAdd -> ParseMul -> ParseNeg -> ParseAtom precedence climb (TPSRC9) Statmnt statements: if/while/repeat/for/case/goto/exit/begin assignment and calls (TPSRC8) ParseType/Decls ARRAY, STRING, scalar/subrange types; variable, constant, label and procedure/function definitions Compile driver: optional PROGRAM header, DefPart, progpart, final '.', header size patch, patch resolution. Ebyte/Eword/Ecall/Ejmp + patch list code emission (TPSRC10). The emitted image is a byte array (mode word, CS/DS, size words, CALL initmem, MOV BP,SP, then generated code). Forward labels and forward procedure calls resolve through a patch list (ptc records). Working subset (v0.4): integer/char/boolean/byte scalars, constants with folding, globals, locals, value parameters, procedures and scalar-result functions, ARRAY[const..const] with constant indexing, control flow, GOTO/EXIT, and the standard procedures WRITE, WRITELN, READ, READLN, HALT (DefBuiltins + IoCall). The standard procedures are dispatched per argument, as the original does (TPSRC8 pwriteln/pwrloop inspects each argument's class and emits a different call per type), so the runtime is handed a value and never a descriptor. Still not implemented: real/set/record/file and the string runtime raise Err (ENoLib) - the original's "not implemented" path. The runtime blob itself, the linker that rebases the TU_* entry offsets by the runtime's size, and CmdRun (the interpreter) are still pending, so a compiled image cannot be executed yet. *) FROM TextBuf IMPORT Length, CharAt ; FROM SYSTEM IMPORT BYTE ; FROM Runtime IMPORT RT_Build, RT_Size, RT_Byte, RT_Entry, LoadBias ; (* The runtime is copied to the front of the code buffer and pc/dc start past it, so every emitted address is image-absolute and no relocation pass is needed. See Inittur. `LoadBias' comes from Runtime because it is the same constant on both sides of the image: Runtime adds it to every data address it bakes into its own code (FixUp, kind 2), and this module adds it to every ABSOLUTE address it bakes into the program's. It is deliberately ONE constant in ONE place rather than 0100h written out at six sites, because getting it wrong at one site is invisible - see the note on LoadBias in Runtime.mod. Relative encodings (the entry JMP, every CALL and JMP) must NOT get it: both operands shift together and the +0100h cancels. *) (* ---------------------------------------------------------------- *) (* constants *) (* ---------------------------------------------------------------- *) CONST MaxLine = 128 ; MaxName = 31 ; (* Size of the entry jump at image offset 0: E9 lo hi. The jump's displacement is relative to the END of the jump, so every offset in the image is EntSize further along than it was before the jump existed. *) EntSize = 3 ; MaxCode = 24000 ; MaxSym = 3000 ; MaxPatch = 2000 ; MaxPend = 400 ; (* type codes (TP3 vartp) *) TNone = 0 ; TArray = 1 ; TRecord = 2 ; TSet = 3 ; TPtr = 4 ; TFile = 5 ; TText = 6 ; TUntyp = 7 ; TString = 8 ; TReal = 9 ; TScalar = 10 ; TBool = 11 ; (* CHAR needs a class of its own. It used to be registered as TScalar, which made a CHAR variable indistinguishable from an INTEGER one: the class is all IoCall has to dispatch on, so `write(c)` called wrint (the value 65 became the *address* 65 and it printed whatever lived at 0x41) and `readln(c)` called rdint (which stores a 16-bit result, so it wrote two bytes into a one-byte variable). TP3 TPSRC8 prdtyped/pwriteln dispatches on the type identifier for exactly this reason. BYTE stays TScalar: a BYTE is written as an integer, as in TP3. *) TChar = 12 ; (* symbol kinds *) KLabel = 100H ; KConst = 200H ; KType = 300H ; KVar = 400H ; KProc = 500H ; KFunc = 600H ; KBuiltin = 700H ; (* standard procedure, see BI_* below *) (* which standard procedure a KBuiltin symbol denotes *) BI_Write = 0 ; BI_WriteLn = 1 ; BI_Read = 2 ; BI_ReadLn = 3 ; BI_Halt = 4 ; (* keyword tokens *) TkNone = 0 ; TkProgram = 1 ; TkBegin = 2 ; TkEnd = 3 ; TkIf = 4 ; TkThen = 5 ; TkElse = 6 ; TkWhile = 7 ; TkDo = 8 ; TkRepeat = 9 ; TkUntil = 10 ; TkFor = 11 ; TkTo = 12 ; TkDownto = 13 ; TkCase = 14 ; TkOf = 15 ; TkGoto = 16 ; TkExit = 17 ; TkWith = 18 ; TkVar = 19 ; TkConst= 20 ; TkType = 21 ; TkLabel = 22 ; TkProcedure = 23 ; TkFunction = 24 ; TkNil = 25 ; TkAnd = 26 ; TkOr = 27 ; TkNot = 28 ; TkDiv = 29 ; TkMod = 30 ; TkIn = 31 ; TkFile = 32 ; TkText = 33 ; TkRecord = 34 ; TkArray = 35 ; TkSet = 36 ; TkPacked = 37 ; TkForward = 38 ; TkExternal = 39 ; TkAbsolute = 40 ; TkOverlay = 41 ; TkString = 42 ; (* Codes for the SYMBOL operators, as BinOpEmit numbers them. The word operators carry their own Tk* token and need no code here. These are named, not bare numbers, because every precedence level's parser picks its own code out of the same set and BinOpEmit cannot see which level called it. ParseAdd chose 1 for '+' and ParseMul chose 1 for '*', so every multiplication dispatched to EmAddAxCx and a * b compiled to a + b. Only the constant-folding path was right, which is why n * n with n a CONST was correct and a * b with a a variable was not. *) OpAdd = 1 ; OpSub = 2 ; OpMul = 3 ; (* TP3 error numbers *) ENoSemi = 1 ; EPointExp = 10 ; ESimpType = 30 ; EUnknown = 41 ; EConstRange = 45 ; EMemOvf = 98 ; ECompOvf = 99 ; ENoLib = 102 ; ETypeErr = 56 ; AposC = 39 ; (* ORD ("'") - avoids quote-in-quote *) (* ---------------------------------------------------------------- *) (* types *) (* ---------------------------------------------------------------- *) TYPE SymEntry = RECORD name : ARRAY [0..MaxName] OF CHAR ; tag : CARDINAL ; cls : CARDINAL ; size : CARDINAL ; elem : CARDINAL ; off : CARDINAL ; lval : LONGINT ; level : CARDINAL ; local : BOOLEAN ; resvar : CARDINAL ; goPos : CARDINAL ; defnd : BOOLEAN ; fwd : BOOLEAN ; END ; PatchRec = RECORD place : CARDINAL ; target : CARDINAL ; filled : BOOLEAN ; END ; PendRec = RECORD kind : CARDINAL ; (* 0 goto, 1 call *) who : CARDINAL ; place : CARDINAL ; (* patch slot index *) END ; ERes = RECORD cls : CARDINAL ; kind : CARDINAL ; (* 0 const, 1 var, 2 value in AX, 3 string literal (cls = TString) *) imm : LONGINT ; idx : CARDINAL ; boff : CARDINAL ; (* constant fold-in for subscripts *) chr : BOOLEAN ; (* single-quoted literal, e.g. 'a' *) strx : CARDINAL ; (* string literal: index into strPool *) END ; DirRec = RECORD rng, chk : BOOLEAN END ; (* ---------------------------------------------------------------- *) (* state *) (* ---------------------------------------------------------------- *) VAR srcPos, srcLen : CARDINAL ; wrd : ARRAY [0..MaxName] OF CHAR ; (* String-literal pool. TP3 does not put a literal in the data segment at all: it emits the literal *inline in the code stream* as , and the runtime entry "wrtinl" reads the length from the return address and returns to just past the last character (TPSRC4 xwrtinl, TPSRC10 estring). So nothing here ends up in the image as data - the pool only has to survive from the moment the literal is scanned until IoCall decides to emit it, because by then the parser has moved on. *) strPool : ARRAY [0..4095] OF CHAR ; strOff : ARRAY [0..255] OF CARDINAL ; strLen : ARRAY [0..255] OF CARDINAL ; strTop : CARDINAL ; (* next free byte in strPool *) strCnt : CARDINAL ; (* literals collected so far *) rdStrX : CARDINAL ; (* pool index of the literal RdConst just read *) symtab : ARRAY [0..MaxSym - 1] OF SymEntry ; symTop : CARDINAL ; patches : ARRAY [0..MaxPatch - 1] OF PatchRec ; nPatch : CARDINAL ; pend : ARRAY [0..MaxPend - 1] OF PendRec ; nPend : CARDINAL ; exitPatch : ARRAY [0..63] OF CARDINAL ; exitCnt : CARDINAL ; brkSave : ARRAY [0..15] OF CARDINAL ; loopTy : ARRAY [0..15] OF CARDINAL ; (* 1 while/repeat, 2 for *) brkN : CARDINAL ; caseJmp : ARRAY [0..63] OF CARDINAL ; caseN : CARDINAL ; pc, dc : CARDINAL ; varspc : CARDINAL ; cbuf : ARRAY [0..MaxCode - 1] OF BYTE ; codeSz, dataSz : CARDINAL ; (* Image layout, all image-absolute. rtSz is where the runtime ends and the program header begins; dataBase is where the data area begins (rtSz + 1000H, a fixed 4 KiB above the code). codeSz and dataSz are PROGRAM sizes - the runtime is excluded - so the numbers the fixture table pins keep meaning what they meant before the runtime was prepended. *) rtSz, dataBase : CARDINAL ; (* Image offset of the entry jump's rel16 operand, patched at the end of Compile. The jump is at image offset 0, so its displacement is simply the program code's end - 3. *) entRel, prologAt : CARDINAL ; (* Runtime entry offsets as IMAGE-ABSOLUTE addresses, which is what EmCall and EmJmp want. They are derived from Runtime.RT_Entry in Inittur (after RT_Build, since RT_Entry only knows where the code landed once the blob is assembled) rather than written down, so a moved entry cannot leave the compiler calling the old address. Not a CONST block because RT_Entry is a function. Standard-procedure entries: TP3 does NOT pass a descriptor - TPSRC8 pwriteln/pwrloop inspects each argument's class in CL and emits a *different* call per type, so the type is fixed at compile time and the runtime needs only the value. Mirrored here. *) TU_InitMem : CARDINAL ; TU_ProgEnd : CARDINAL ; TU_StackChk : CARDINAL ; TU_WrInt : CARDINAL ; TU_WrChar : CARDINAL ; TU_WrBool : CARDINAL ; TU_WrReal : CARDINAL ; TU_WrLn : CARDINAL ; TU_RdInt : CARDINAL ; TU_RdChar : CARDINAL ; TU_RdBool : CARDINAL ; TU_RdLn : CARDINAL ; TU_Halt : CARDINAL ; TU_WrInl : CARDINAL ; (* inline string literal; NO stack argument *) 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 PatchWord (at, w : CARDINAL) ; (* Store a 16-bit word into cbuf at an absolute offset. A helper, because writing this inline got it wrong in all four header words: the low byte was (w DIV 16) MOD 100H, which is a NIBBLE shift, not the byte shift (w MOD 100H). So 1181h - the data base - was stored as 0118h = 280. It was invisible for as long as nothing read those words, which is exactly what "write it inline once and trust it" buys you. *) BEGIN cbuf [at] := VAL (BYTE, w MOD 100H) ; cbuf [at + 1] := VAL (BYTE, (w DIV 100H) MOD 100H) END PatchWord ; PROCEDURE AddPatch (place, target : CARDINAL) ; BEGIN IF nPatch < MaxPatch THEN patches [nPatch].place := place ; patches [nPatch].target := target ; patches [nPatch].filled := FALSE ; INC (nPatch) ELSE Err (ECompOvf) END END AddPatch ; PROCEDURE SetPatTgt (idx, t : CARDINAL) ; BEGIN IF idx < nPatch THEN patches [idx].target := t END END SetPatTgt ; PROCEDURE EmCall (target : CARDINAL) : CARDINAL ; (* E8 rel16 near call; target = 0 => forward (patched later). Returns the patch slot, or 0 when resolved directly. *) VAR rel, p : CARDINAL ; BEGIN Ebyte (0E8H) ; IF target = 0 THEN Eword (0) ; p := nPatch ; AddPatch (pc - 2, 0) ; RETURN p END ; (* rel16 is measured from the END of the instruction. Here pc already points past the opcode(s) and at the displacement field, so the instruction ends at pc+2 - the same convention ResolvePatches uses with "place + 2". Omitting the +2 lands every direct call/jump 2 bytes past its target. *) rel := (target + 10000H - (pc + 2)) MOD 10000H ; Eword (rel) ; RETURN 0 END EmCall ; PROCEDURE EmJmpNear (target : CARDINAL) : CARDINAL ; (* E9 rel16; target = 0 => forward. Returns patch slot or 0. *) VAR rel, p : CARDINAL ; BEGIN Ebyte (0E9H) ; IF target = 0 THEN Eword (0) ; p := nPatch ; AddPatch (pc - 2, 0) ; RETURN p END ; rel := (target + 10000H - (pc + 2)) MOD 10000H ; (* see EmCall *) Eword (rel) ; RETURN 0 END EmJmpNear ; PROCEDURE JccShort (cc : BYTE) : BYTE ; (* The 8086 SHORT Jcc opcode for a condition nibble. 70h..7Fh is exactly 70h + nibble: 70 JO 71 JNO 72 JB 73 JAE 74 JE 75 JNE 76 JBE 77 JA 78 JS 79 JNS 7A JP 7B JNP 7C JL 7D JGE 7E JLE 7F JG. So 70H + cc is the same condition the 386-only `0F 8x rel16' (for a Jcc) or `0F 9x' (for a SETcc) encoded, which is what lets the seven EmJcc sites and the six EmSetcc arms go on passing the low byte they always passed. *) VAR n : CARDINAL ; BEGIN n := VAL (CARDINAL, cc) MOD 10H ; RETURN VAL (BYTE, 70H + n) END JccShort ; PROCEDURE JccShortInv (cc : BYTE) : BYTE ; (* The same, for a jump that is taken when the condition does NOT hold. EmJcc needs this one and EmSetcc needs the other, and the difference is the whole bug, so it is worth being explicit about where it comes from: the low bit of a Jcc code IS the negation bit. 4/5, C/D, E/F, 2/3, 6/7, A/9, B/8 and 0/1 are the eight (condition, its negation) pairs, so negating a condition is `n XOR 1' and nothing more - `JE' and `JNE' are 0x74 and 0x75. Gm2 under -fiso has no XOR on integers at all: BITAND and BAND are both syntax errors, and arithmetic on a BYTE operand is rejected too, which is why every operand here goes through VAL. n + 1 - 2*(n MOD 2) is XOR 1 for a four-bit n and it lives in one named place rather than open-coded, because an open-coded negation at two call sites is how they end up disagreeing. *) VAR n : CARDINAL ; BEGIN n := VAL (CARDINAL, cc) MOD 10H ; RETURN VAL (BYTE, 70H + n + 1 - 2 * (n MOD 2)) END JccShortInv ; PROCEDURE EmJcc (cc : BYTE ; target : CARDINAL) : CARDINAL ; (* A conditional branch, 8086 style. `cc' is the condition nibble, and it is exactly the low byte of the `0F 8x rel16' this used to emit. That was a real fault and nothing in the build could see it: `0F' is a 386-and-later opcode prefix and the 8086 has none, so EVERY conditional branch in EVERY compiled program was an illegal instruction on the machine TP3 targets. FCML decoded it happily, because FCML's -m16 mode is 386 -- and FCML is this project's independent disassembler, so the one tool that could have objected was the one guaranteed to agree. qemu-system-i386 has no 8086 model either; its lowest is 486. So the compile succeeded, the .COM linked, the layout checked, the golden held and all 30 fixtures ran to the right answers, all at once, with the bug in. TPSRC8 lays IF, WHILE and REPEAT out as MOV AL,brnchop ; MOV AH,#$03 ; CALL eword ; PUSH pc ; CALL ejump i.e. a SHORT Jcc of displacement 3, stepping over a 3-byte EJMP. That is the shape here too, and EmJmpNear already owns the displacement arithmetic and the patch slot, so it is three lines and there is no second copy of that rule. The one thing that is NOT the same as TPSRC8, and cost a round of "every conditional is inverted" (t09_if printed pos/nonpos/lt for a program that must print nonpos/pos/ge): TP3's brnchop is the branch taken when the condition is TRUE, and TP3 steps over the EJMP when it is taken. Here `cc' is the branch taken when the condition is FALSE -- IF's `EmJcc (84H)' is JZ, patched to the ELSE, so it must fire when the test failed. EmJcc jumps to the target, it does not step over it, so stepping over an EJMP and then falling into the destination is the wrong way round: the byte has to be JccShortInv, not JccShort. The control flow that comes out is identical to the `0F 8x' form this replaces; only which of the pair is spelled differs. The flags survive, and the FOR test needs them to: it emits CMP and then Jcc with nothing in between, so anything that wrote a flag here would break the loop. Jcc and EJMP both leave the flags alone. *) BEGIN Ebyte (JccShortInv (cc)) ; (* Jcc_s, taken when cc does NOT hold *) Ebyte (03H) ; (* rel8: step over the 3-byte EJMP *) RETURN EmJmpNear (target) (* target = 0 => forward, see above *) END EmJcc ; PROCEDURE ResolvePatches () ; VAR i : CARDINAL ; rel : CARDINAL ; BEGIN i := 0 ; WHILE i < nPatch DO IF NOT patches [i].filled THEN rel := (patches [i].target + 10000H - (patches [i].place + 2)) MOD 10000H ; cbuf [patches [i].place] := VAL (BYTE, rel MOD 100H) ; cbuf [patches [i].place + 1] := VAL (BYTE, (rel DIV 100H) MOD 100H) ; patches [i].filled := TRUE END ; INC (i) END END ResolvePatches ; (* 1-byte const emitters *) PROCEDURE EmMovAxi (imm : CARDINAL) ; BEGIN Ebyte (0B8H) ; Eword (imm) END EmMovAxi ; PROCEDURE EmMovBpSp () ; BEGIN Ebyte (8BH) ; Ebyte (0ECH) END EmMovBpSp ; PROCEDURE EmMovAh0 () ; BEGIN Ebyte (0B4H) ; Ebyte (0H) END EmMovAh0 ; PROCEDURE EmMovAxSp () ; (* Read the top of the stack into AX, leaving the stack unchanged. The obvious encoding, MOV AX,[SP], DOES NOT EXIST on the 8086. There is no encoding of [SP] as a memory operand: SIB bytes, which is how [ESP] would be written, did not exist until the 386, and mod=00 / rm=100 is [SI], not [SP]. The first version of this emitted 8B 44 24 00 - mod=01, rm=100, SIB=24h, disp8=0 - which is correct only on a 386 and above. Two of this project's oracles agree that it is wrong: fcml in 16-bit mode decodes it as MOV AX,[SI+0x24h], and so does qemu executing it, because qemu follows the CPU's rules for the encoding it is given rather than guessing. It was not the encoder's fault that the bytes were well formed; they were, and they read SI+24h. The observable effect was that CASE compiled to no branches at all: each label test loaded a garbage address, every comparison failed, and the program fell straight past the whole statement and exited without printing. A CASE fixture caught it. Nothing else could have - the encoding is valid, the size is right, and the byte-level checks have no way to know what register was meant. So: POP then PUSH the same value. Two bytes, no SIB, correct on every 8086, and observationally identical to peeking - the stack pointer ends where it started, holding the same value. *) BEGIN Ebyte (58H) ; (* POP AX *) Ebyte (50H) (* PUSH AX *) END EmMovAxSp ; PROCEDURE EmMovCxSp () ; (* The same, for CX - the FOR loop's bound, pushed by the FOR statement and re-read on every iteration. This one was emitting 8B 0C and nothing else, which is MOV CX,[SI] with the SIB slot missing: the *next* instruction was consumed as the SIB byte and the displacement. Same root cause, same fix, and it had not been noticed only because no FOR fixture is executed yet. *) BEGIN Ebyte (59H) ; (* POP CX *) Ebyte (51H) (* PUSH CX *) END EmMovCxSp ; PROCEDURE EmPushAx () ; BEGIN Ebyte (50H) END EmPushAx ; PROCEDURE EmPopCx () ; BEGIN Ebyte (59H) END EmPopCx ; PROCEDURE EmPopDx () ; BEGIN Ebyte (5AH) END EmPopDx ; (* 91 = XCHG AX,CX, and NOT 93. BinOpEmit has the left operand in CX and the right in AX (it pushes the left, loads the right, then pops the left into CX), so the exchange is what puts LEFT in AX for the operation to act on. Without it, `a - b` computes `b - a`; with the wrong register, `a + b` computes `AX' + a` where AX' is whatever BX happened to hold. This emitted 93H = XCHG BX,AX for its entire life, which is the same class of mistake as MovSiBx = 89 DC in Runtime.mod: the right opcode, the wrong ModRM, decoding cleanly. Byte counts were right, the compile matrix was green, and no exec fixture did arithmetic on two variables - the first one to do so, `c := a + b` with a=7 b=5, printed 263 = 0100h+7, where 0100h was the caller's leftover BX. The name was the only thing wrong, and nothing read the name: audit_helpers.py swept Runtime.mod and not Compiler.mod, which is where most of these emitters live. It does both modules now. *) PROCEDURE EmXchgAxCx () ; BEGIN Ebyte (91H) END EmXchgAxCx ; PROCEDURE EmXorAxAx () ; BEGIN Ebyte (33H) ; Ebyte (0C0H) END EmXorAxAx ; PROCEDURE EmAddAxCx () ; BEGIN Ebyte (3H) ; Ebyte (0C1H) END EmAddAxCx ; PROCEDURE EmSubAxCx () ; BEGIN Ebyte (2BH) ; Ebyte (0C1H) END EmSubAxCx ; PROCEDURE EmMulAxCx () ; BEGIN Ebyte (0F7H) ; Ebyte (0E9H) END EmMulAxCx ; PROCEDURE EmIDivAxCx () ; BEGIN Ebyte (99H) ; Ebyte (0F7H) ; Ebyte (0F9H) END EmIDivAxCx ; PROCEDURE EmAndAxCx () ; BEGIN Ebyte (23H) ; Ebyte (0C1H) END EmAndAxCx ; PROCEDURE EmOrAxCx () ; BEGIN Ebyte (0BH) ; Ebyte (0C1H) END EmOrAxCx ; PROCEDURE 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) ; (* Flags -> a Boolean in AX, on an 8086. `cc' is the SETcc opcode's low byte (94H = E, 95H = NE, 9CH = L, 9DH = GE, 9EH = LE, 9FH = G), i.e. the same condition nibble EmJcc takes. This used to emit `0F cc C0' - SETcc - which is 386-and-later, and then a MOV AH,0. The 8086 cannot read its flags as a value at all, so there was nothing else to fall back on. TPSRC9's flgbool is the fallback, and emits exactly this for exactly this case (CH = 04h, a comparison whose result is wanted as a value rather than as a branch): CALL ecode ; B $03,$B8,$01,$00 -> MOV AX,#0001 MOV AL,brnchop ; CALL ebyte -> JNZ +1 CALL ecode ; B $02,$01,$48 -> DEC AX AX stays 1 because the DEC was stepped over, and becomes 0 because it ran. So the shape is one MOV, one short Jcc whose displacement is the length of the DEC, and the DEC - which is EmJcc's shape with a different displacement, and the reason both are two instructions and a byte. The polarity is the opposite of EmJcc's, and deliberately so: here the jump must be taken when the comparison is TRUE, because what is being asked is "is this comparison true", and the nibble the six ParseCmp arms pass is the comparison's own opcode. So this is JccShort and EmJcc is JccShortInv -- see EmJcc for why the difference is there at all. TP3's flgbool writes JNZ for the same reason; in the one case IT reaches flgbool from, the boolean is sitting in AX rather than in the flags, so JNZ is how it says "AX is non-zero". AH comes out 0 for free, which is why the EmMovAh0 this used to end with is gone: 6 bytes here where the old sequence was 5. The FLAGS do not survive, which the old SETcc did - and nothing reads them. Every conditional branch in the compiler is preceded by its own CMP (see EmJcc's note on the FOR test), and a comparison's value is consumed either as an AX operand or by the test that follows it; the 30 executed fixtures are what holds that down, not this comment. *) BEGIN Ebyte (0B8H) ; Eword (1) ; (* MOV AX,#0001 *) Ebyte (JccShort (cc)) ; (* taken when the comparison HOLDS *) Ebyte (01H) ; (* rel8: step over the DEC AX *) Ebyte (48H) (* DEC AX *) END EmSetcc ; PROCEDURE EmIncAx () ; BEGIN Ebyte (40H) END EmIncAx ; PROCEDURE EmDecAx () ; BEGIN Ebyte (48H) END EmDecAx ; PROCEDURE EmBpDisp (off : CARDINAL) ; (* Emit the ModR/M byte and displacement for a [BP+off] operand, picking the encoding from the size of off. This is the ONE place that choice is made, because getting it wrong is invisible: 8B 46 d8 and 8B 86 lo hi are both well-formed MOVs, both decode cleanly, and only one of them reads the variable the symbol table names. So the two are chosen here, once, rather than re-derived at each of the four call sites. See the ModR/M table in Runtime.mod. off <= 127 -> mod=01 rm=110 -> 46 3 bytes with the opcode otherwise -> mod=10 rm=110 -> 86 4 bytes with the opcode Both displacements are SIGNED, and that is the whole subtlety: - `off` is a 16-bit value and locals are allocated DOWNWARD from 0FFFEh (locFree starts there and is decremented per declaration), so the first local of a procedure sits at off = 0FFFC, which is -4. The disp16 form reads those same two bytes as a signed value and addresses [BP-4] correctly. There is no overflow case: all 65536 values of `off` are representable, and a frame larger than 64K is a different problem. - The old code took `off MOD 100H` and always emitted disp8. That is the correct low byte for every displacement, so it was accidentally right across -32768..+127, which is where locals actually live. It went wrong at +128, where disp8 80h is -128 and not +128. So this changes no existing program's bytes and fixes the one case that was broken -- a bug nobody had hit yet, which is exactly why it wanted a test rather than an argument. *) BEGIN IF off <= 127 THEN Ebyte (46H) ; Ebyte (VAL (BYTE, off)) ELSE Ebyte (86H) ; Eword (off) END END EmBpDisp ; PROCEDURE EmLoadVar (local : BOOLEAN ; off, nbytes : CARDINAL) ; (* A local is [BP+off] and `off' is already a frame displacement, so it needs no bias. A global is [off] with a DIRECT displacement, i.e. an absolute address, and that is the image offset + LoadBias - see Runtime.LoadBias. *) BEGIN IF nbytes = 1 THEN IF local THEN Ebyte (8AH) ; EmBpDisp (off) ELSE Ebyte (0A0H) ; Eword ((off + LoadBias) MOD 10000H) END ELSE IF local THEN Ebyte (8BH) ; EmBpDisp (off) ELSE Ebyte (0A1H) ; Eword ((off + LoadBias) MOD 10000H) END END END EmLoadVar ; PROCEDURE EmStoreVar (local : BOOLEAN ; off, nbytes : CARDINAL) ; BEGIN IF nbytes = 1 THEN IF local THEN Ebyte (88H) ; EmBpDisp (off) ELSE Ebyte (0A2H) ; Eword ((off + LoadBias) MOD 10000H) END ELSE IF local THEN Ebyte (89H) ; EmBpDisp (off) ELSE Ebyte (0A3H) ; Eword ((off + LoadBias) MOD 10000H) END END END EmStoreVar ; PROCEDURE EmPushVarAddr (local : BOOLEAN ; off : CARDINAL) ; (* LEA AX,[BP+disp] / LEA AX,[off] then PUSH AX - READ passes the address of a variable, not its value. 8D 46 disp is LEA AX,[BP+disp8] and 8D 86 lo hi is LEA AX,[BP+disp16]; 8D 06 off is LEA AX,[off] (mod=00 rm=110 = the direct disp16 form). All three are 8086-legal. The [off] form is absolute and so carries LoadBias; the [BP+disp] forms are displacements and so do not. *) BEGIN IF local THEN Ebyte (8DH) ; EmBpDisp (off) ELSE Ebyte (8DH) ; Ebyte (06H) ; Eword ((off + LoadBias) MOD 10000H) END ; EmPushAx () END EmPushVarAddr ; PROCEDURE EmSubSp (n : CARDINAL) ; BEGIN Ebyte (81H) ; Ebyte (0ECH) ; Eword (n MOD 10000H) END EmSubSp ; PROCEDURE EmAddSp (n : CARDINAL) ; BEGIN IF n <= 126 THEN Ebyte (83H) ; Ebyte (0C4H) ; Ebyte (VAL (BYTE, n)) ELSE Ebyte (81H) ; Ebyte (0C4H) ; Eword (n MOD 10000H) END END EmAddSp ; PROCEDURE EmPushBp () ; BEGIN Ebyte (55H) END EmPushBp ; PROCEDURE EmLeave () ; BEGIN Ebyte (0C9H) END EmLeave ; PROCEDURE EmRet () ; BEGIN Ebyte (0C3H) END EmRet ; (* ---------------------------------------------------------------- *) (* symbol table *) (* ---------------------------------------------------------------- *) PROCEDURE NameEq (a : ARRAY OF CHAR ; b : ARRAY OF CHAR) : BOOLEAN ; VAR i : CARDINAL ; BEGIN i := 0 ; LOOP IF i > HIGH (a) THEN RETURN FALSE END ; IF i > HIGH (b) THEN RETURN FALSE END ; IF a [i] # b [i] THEN RETURN FALSE END ; IF a [i] = 0C THEN RETURN TRUE END ; INC (i) END END NameEq ; PROCEDURE CopyStr (VAR dst : ARRAY OF CHAR ; src : ARRAY OF CHAR) ; VAR i : CARDINAL ; BEGIN i := 0 ; LOOP IF i > HIGH (dst) THEN dst [HIGH (dst)] := 0C ; RETURN END ; IF i > HIGH (src) THEN dst [i] := 0C ; RETURN END ; dst [i] := src [i] ; IF src [i] = 0C THEN RETURN END ; INC (i) END END CopyStr ; PROCEDURE CopyWord (name : ARRAY OF CHAR) ; (* stash current word into global wrd (uppercased) *) VAR i : CARDINAL ; BEGIN i := 0 ; LOOP IF i > HIGH (name) THEN wrd [i] := 0C ; RETURN END ; IF i > MaxName THEN wrd [MaxName] := 0C ; RETURN END ; IF name [i] = 0C THEN wrd [i] := 0C ; RETURN END ; wrd [i] := Upper (name [i]) ; INC (i) END END CopyWord ; PROCEDURE SaveWord (VAR dst : ARRAY OF CHAR) ; (* copy wrd into dst *) VAR i : CARDINAL ; BEGIN i := 0 ; LOOP IF i > HIGH (dst) THEN dst [HIGH (dst)] := 0C ; RETURN END ; IF i > MaxName THEN dst [MaxName] := 0C ; RETURN END ; dst [i] := wrd [i] ; IF wrd [i] = 0C THEN RETURN END ; INC (i) END END SaveWord ; PROCEDURE NumToName (n : CARDINAL ; VAR dst : ARRAY OF CHAR) ; VAR buf : ARRAY [0..9] OF CHAR ; i, j : CARDINAL ; BEGIN IF n = 0 THEN dst [0] := '0' ; dst [1] := 0C ; RETURN END ; i := 0 ; WHILE n > 0 DO IF i <= 9 THEN buf [i] := CHR (ORD ('0') + (n MOD 10)) ; INC (i) END ; n := n DIV 10 END ; j := 0 ; WHILE i > 0 DO DEC (i) ; IF j <= HIGH (dst) THEN dst [j] := buf [i] ; INC (j) END END ; IF j <= HIGH (dst) THEN dst [j] := 0C END END NumToName ; PROCEDURE NewSym (name : ARRAY OF CHAR ; tag : CARDINAL ; cls, size, elem, off : CARDINAL ; v : LONGINT ; local : BOOLEAN) : CARDINAL ; VAR e : SymEntry ; BEGIN IF symTop >= MaxSym THEN Err (ECompOvf) ; RETURN 0 END ; CopyWord (name) ; CopyStr (e.name, wrd) ; e.tag := tag ; e.cls := cls ; e.size := size ; e.elem := elem ; e.off := off ; e.lval := v ; e.level := lexnest ; e.local := local ; e.resvar := 0 ; e.goPos := 0 ; e.defnd := FALSE ; e.fwd := FALSE ; symtab [symTop] := e ; INC (symTop) ; RETURN symTop - 1 END NewSym ; PROCEDURE Search (nm : ARRAY OF CHAR ; VAR idx : CARDINAL) : BOOLEAN ; (* find nm among symbols visible at the current lexical level *) VAR p : CARDINAL ; BEGIN CopyWord (nm) ; p := symTop ; WHILE p > 0 DO DEC (p) ; IF symtab [p].level <= lexnest THEN IF NameEq (symtab [p].name, wrd) THEN idx := p ; RETURN TRUE END END END ; RETURN FALSE END Search ; PROCEDURE DupTest (nm : ARRAY OF CHAR) ; VAR i : CARDINAL ; BEGIN IF Search (nm, i) THEN Err (EUnknown) END END DupTest ; PROCEDURE HideLocals (from : CARDINAL) ; (* Make every symbol from index `from' up invisible to everything outside the procedure that declared it. Search accepts a symbol when its level is <= lexnest, and every procedure body is compiled at the same depth (lexnest 1), so a finished procedure's parameters stayed visible to the NEXT procedure: a second `a : integer' was a duplicate (err 41) and an unqualified `a' inside procedure two read procedure one's argument. Level 0FFFFH fails `level <= lexnest' at every depth a later procedure can be at, and by the time this runs the body that could still legitimately see them is finished. The symbols are relabelled, not popped: symtab[old].resvar holds an INDEX, and a function's result variable is one of the entries being hidden. *) VAR p : CARDINAL ; BEGIN p := from ; WHILE p < symTop DO symtab [p].level := 0FFFFH ; INC (p) END END HideLocals ; (* ---------------------------------------------------------------- *) (* lexer *) (* ---------------------------------------------------------------- *) PROCEDURE InitKeys () ; VAR i : CARDINAL ; BEGIN FOR i := 0 TO 42 DO kTk [i] := 0 ; kName [i] [0] := 0C END ; kName [1] := "PROGRAM" ; kTk [1] := TkProgram ; kName [2] := "BEGIN" ; kTk [2] := TkBegin ; kName [3] := "END" ; kTk [3] := TkEnd ; kName [4] := "IF" ; kTk [4] := TkIf ; kName [5] := "THEN" ; kTk [5] := TkThen ; kName [6] := "ELSE" ; kTk [6] := TkElse ; kName [7] := "WHILE" ; kTk [7] := TkWhile ; kName [8] := "DO" ; kTk [8] := TkDo ; kName [9] := "REPEAT" ; kTk [9] := TkRepeat ; kName [10] := "UNTIL" ; kTk [10] := TkUntil ; kName [11] := "FOR" ; kTk [11] := TkFor ; kName [12] := "TO" ; kTk [12] := TkTo ; kName [13] := "DOWNTO" ; kTk [13] := TkDownto ; kName [14] := "CASE" ; kTk [14] := TkCase ; kName [15] := "OF" ; kTk [15] := TkOf ; kName [16] := "GOTO" ; kTk [16] := TkGoto ; kName [17] := "EXIT" ; kTk [17] := TkExit ; kName [18] := "WITH" ; kTk [18] := TkWith ; kName [19] := "VAR" ; kTk [19] := TkVar ; kName [20] := "CONST" ; kTk [20] := TkConst ; kName [21] := "TYPE" ; kTk [21] := TkType ; kName [22] := "LABEL" ; kTk [22] := TkLabel ; kName [23] := "PROCEDURE" ; kTk [23] := TkProcedure ; kName [24] := "FUNCTION" ; kTk [24] := TkFunction ; kName [25] := "NIL" ; kTk [25] := TkNil ; kName [26] := "AND" ; kTk [26] := TkAnd ; kName [27] := "OR" ; kTk [27] := TkOr ; kName [28] := "NOT" ; kTk [28] := TkNot ; kName [29] := "DIV" ; kTk [29] := TkDiv ; kName [30] := "MOD" ; kTk [30] := TkMod ; kName [31] := "IN" ; kTk [31] := TkIn ; kName [32] := "FILE" ; kTk [32] := TkFile ; kName [33] := "TEXT" ; kTk [33] := TkText ; kName [34] := "RECORD" ; kTk [34] := TkRecord ; kName [35] := "ARRAY" ; kTk [35] := TkArray ; kName [36] := "SET" ; kTk [36] := TkSet ; kName [37] := "PACKED" ; kTk [37] := TkPacked ; kName [38] := "FORWARD" ; kTk [38] := TkForward ; kName [39] := "EXTERNAL" ; kTk [39] := TkExternal ; kName [40] := "ABSOLUTE" ; kTk [40] := TkAbsolute ; kName [41] := "OVERLAY" ; kTk [41] := TkOverlay ; kName [42] := "STRING" ; kTk [42] := TkString END InitKeys ; PROCEDURE IsBlank (ch : CHAR) : BOOLEAN ; BEGIN RETURN (ch = ' ') OR (ORD (ch) = 09H) OR (ORD (ch) = 0DH) OR (ORD (ch) = 0AH) OR (ORD (ch) = 0CH) END IsBlank ; PROCEDURE Skip () ; (* blanks, comments { } and (* *), compiler directives {$ } / (*$ *) letter + sign toggles rng/chk *) 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 DeclaresProc () : BOOLEAN ; (* Does the REST of the source declare a PROCEDURE or a FUNCTION? Needed because the declaration part is compiled BEFORE the main statement part, so a procedure's code lands between the program prologue and the main body - and nothing jumps over it. A program with a procedure therefore ran off the end of the prologue, straight into the first procedure, which read its argument out of an uninitialised frame and returned to address 0. Every Pascal program containing a procedure was broken; `t13_proc` compiled and was never executed, so nothing saw it. The jump that fixes it has to be emitted BEFORE the declaration part, but whether one is needed is only known AFTER - so the only honest options are to emit it unconditionally (3 dead bytes in every program, and every code size in expected.tsv moves) or to know the answer in advance. This is the second: it scans ahead and puts srcPos back. That is safe because the whole program is already in `src` and `srcPos` is a plain index into it - the same trick PeekKw and KwAhead use. The scan looks for the keywords anywhere in the remainder rather than tracking the nesting of `begin`s, which is deliberately loose: a program with no procedures that merely mentions the word in a string literal would get a 3-byte jump to the next instruction, which is harmless, whereas tracking the main `begin` against a procedure's `begin` would be a second parser to get wrong. *) VAR save : CARDINAL ; found : BOOLEAN ; tk : CARDINAL ; ch : CHAR ; BEGIN save := srcPos ; found := FALSE ; tk := TkNone ; (* so the answer is defined if src is empty *) (* Step over delimiters as well as blanks. Stopping at the first non-letter looked reasonable and was wrong: `var x : integer ;` is full of ':' and ';', so the scan gave up inside the variable section and never reached the PROCEDURE. The loop ends at the end of the source, not at the first punctuation. *) WHILE (NOT found) AND (srcPos < srcLen) DO Skip () ; IF Alpha (CurCh ()) THEN GetWord () ; tk := WddTok () ; IF (tk = TkProcedure) OR (tk = TkFunction) THEN found := TRUE END ELSE ch := GetCh () (* a ':' or ';' - step over it *) END END ; srcPos := save ; RETURN (tk = TkProcedure) OR (tk = TkFunction) END DeclaresProc ; PROCEDURE KwAhead (word : ARRAY OF CHAR) : BOOLEAN ; (* does the next token (past blanks/comments) equal the keyword 'word', without consuming it? srcPos is saved and restored. *) VAR save : CARDINAL ; k : BOOLEAN ; BEGIN save := srcPos ; Skip () ; k := FALSE ; IF Alpha (CurCh ()) THEN GetWord () ; k := NameEq (wrd, word) END ; srcPos := save ; RETURN k END KwAhead ; PROCEDURE PeekKw (VAR tok : CARDINAL) ; (* peek at the next keyword token without consuming it *) VAR i : CARDINAL ; BEGIN tok := TkNone ; i := 1 ; WHILE i <= 42 DO IF kName [i] [0] # 0C THEN IF KwAhead (kName [i]) THEN tok := kTk [i] ; RETURN END END ; INC (i) END END PeekKw ; PROCEDURE MatchKey (VAR tok : CARDINAL) : BOOLEAN ; (* skip; if next symbol is a word, read it into wrd and set its token. Returns TRUE when a word was read (tok = TkNone for plain ids). *) BEGIN tok := TkNone ; Skip () ; IF NOT Alpha (CurCh ()) THEN RETURN FALSE END ; GetWord () ; tok := WddTok () ; RETURN TRUE END MatchKey ; PROCEDURE MatchDelim (ch : CHAR) : BOOLEAN ; BEGIN Skip () ; IF CurCh () = ch THEN DropCh (GetCh ()) ; RETURN TRUE END ; RETURN FALSE END MatchDelim ; PROCEDURE MatchAssign () : BOOLEAN ; BEGIN Skip () ; IF (CurCh () = ':') AND (PeekAhead (1) = '=') THEN DropCh (GetCh ()) ; DropCh (GetCh ()) ; RETURN TRUE END ; RETURN FALSE END MatchAssign ; PROCEDURE MatchRange () : BOOLEAN ; BEGIN Skip () ; IF (CurCh () = '.') AND (PeekAhead (1) = '.') THEN DropCh (GetCh ()) ; DropCh (GetCh ()) ; RETURN TRUE END ; RETURN FALSE END MatchRange ; PROCEDURE ExpectDelim (ch : CHAR ; n : CARDINAL) ; BEGIN Skip () ; IF CurCh () = ch THEN DropCh (GetCh ()) ELSE Err (n) END END ExpectDelim ; PROCEDURE HexVal (ch : CHAR) : CARDINAL ; BEGIN IF (ch >= '0') AND (ch <= '9') THEN RETURN ORD (ch) - ORD ('0') ELSIF (ch >= 'A') AND (ch <= 'F') THEN RETURN ORD (ch) - ORD ('A') + 10 END ; RETURN ORD (ch) - ORD ('a') + 10 END HexVal ; PROCEDURE RdIntConst (VAR v : LONGINT) ; (* bare integer constant; current char is digit or '$' *) VAR acc : LONGINT ; BEGIN acc := 0 ; IF CurCh () = '$' THEN DropCh (GetCh ()) ; WHILE IsHexCh (CurCh ()) DO acc := acc * 16 + VAL (LONGINT, HexVal (CurCh ())) ; DropCh (GetCh ()) END ELSE WHILE Digit (CurCh ()) DO acc := acc * 10 + VAL (LONGINT, ORD (CurCh ()) - ORD ('0')) ; DropCh (GetCh ()) END END ; v := acc END RdIntConst ; PROCEDURE StrNew (first : CARDINAL ; hasFirst : BOOLEAN ) : CARDINAL ; (* Open a pool slot for a string literal, optionally pre-seeded with its first character. RdConst has to read the first character before it can tell a one-character literal from a longer one - the "is the next character another quote?" test only makes sense once something has been read - so the seeding has to happen here and has to advance strTop. Leaving strTop alone and letting the caller write the character by hand is a trap: strTop is the next FREE byte, so the first StrPut lands on top of the seeded character and overwrites it. (That bug shipped the literal 'hi' as 69 00 - 'i' then NUL.) *) VAR x : CARDINAL ; BEGIN IF strCnt > HIGH (strOff) THEN Err (ECompOvf) ; (* too many literals in one unit *) RETURN 0 END ; x := strCnt ; strOff [x] := strTop ; strLen [x] := 0 ; INC (strCnt) ; IF hasFirst THEN strPool [strTop] := CHR (first) ; INC (strTop) ; strLen [x] := 1 END ; rdStrX := x ; RETURN x END StrNew ; PROCEDURE StrPut (x : CARDINAL ) ; (* append the current source character to pool slot x *) BEGIN IF x > HIGH (strOff) THEN RETURN END ; IF strTop > HIGH (strPool) THEN Err (ECompOvf) ; (* literal longer than the pool *) RETURN END ; strPool [strTop] := CurCh () ; INC (strTop) ; INC (strLen [x]) END StrPut ; PROCEDURE RdConst (VAR v : LONGINT ; VAR cls : CARDINAL ; VAR isStr : BOOLEAN) ; (* scalar or string constant. A string literal's text is collected into the pool and its slot index left in rdStrX; a single-character literal stays a TScalar holding its character code, which is what "c := 'a'" wants. *) CONST q = AposC ; BEGIN isStr := FALSE ; cls := TScalar ; v := 0 ; Skip () ; IF CurCh () = '$' THEN RdIntConst (v) ; cls := TScalar ELSIF Digit (CurCh ()) THEN RdIntConst (v) ; IF (CurCh () = '.') AND (Digit (PeekAhead (1))) THEN cls := TReal ; DropCh (GetCh ()) END ; IF (CurCh () = 'E') OR (CurCh () = 'e') THEN cls := TReal ; DropCh (GetCh ()) END ; IF cls = TReal THEN WHILE AlphaNum (CurCh ()) OR (CurCh () = '.') OR (CurCh () = '-') OR (CurCh () = '+') DO DropCh (GetCh ()) END END ELSIF ORD (CurCh ()) = q THEN DropCh (GetCh ()) ; IF ORD (CurCh ()) = q THEN (* '' - the empty string. It used to be reported as the scalar 39, so writeln('') printed a single quote mark. It is a string of length zero, and an inline zero-length literal is exactly what the runtime's JCXZ path is for. *) DropCh (GetCh ()) ; isStr := TRUE ; cls := TString ; v := 0 ; rdStrX := StrNew (0, FALSE) ELSIF (CurCh () = 0C) OR ((ORD (CurCh ()) = 0DH)) OR ((ORD (CurCh ()) = 0AH)) THEN Err (EUnknown) ELSE v := VAL (LONGINT, ORD (GetCh ())) ; cls := TScalar ; IF ORD (CurCh ()) = q THEN DropCh (GetCh ()) ELSE isStr := TRUE ; cls := TString ; (* Scan to the closing quote. NB: the loop condition must test the CURRENT character and only the current character. The obvious-looking "while CurCh # quote" with a "if PeekAhead(1) = quote then consume two" body is wrong: consuming the quote moves the cursor past it, so the next condition test sees the character AFTER the literal, is satisfied, and the scan runs on to end-of-buffer - which silently eats the rest of the program and makes every later error point at end-of-file. Stop on the quote itself, and treat a doubled quote as one embedded quote character. The first character is already gone - it was read into v above - so the pool slot is pre-seeded with it. *) rdStrX := StrNew (VAL (CARDINAL, v), TRUE) ; LOOP IF ORD (CurCh ()) = q THEN IF ORD (PeekAhead (1)) = q THEN StrPut (rdStrX) ; (* '' inside *) DropCh (GetCh ()) ; DropCh (GetCh ()) ELSE EXIT (* closing quote *) END ELSIF (CurCh () = 0C) OR (ORD (CurCh ()) = 0DH) THEN Err (EUnknown) ; (* unterminated *) EXIT ELSE StrPut (rdStrX) ; DropCh (GetCh ()) END END ; IF ORD (CurCh ()) = q THEN DropCh (GetCh ()) END END END ELSE Err (EUnknown) END END RdConst ; (* ---------------------------------------------------------------- *) (* forward declarations *) (* ---------------------------------------------------------------- *) PROCEDURE ParseExpr (VAR r : ERes) ; FORWARD ; PROCEDURE ParseAdd (VAR r : ERes) ; FORWARD ; PROCEDURE ParseMul (VAR r : ERes) ; FORWARD ; PROCEDURE ParseNeg (VAR r : ERes) ; FORWARD ; PROCEDURE ParseAtom (VAR r : ERes) ; FORWARD ; PROCEDURE ParseType (VAR cls, size, elem : CARDINAL) ; FORWARD ; PROCEDURE Statmnt () ; FORWARD ; PROCEDURE ParseCall (idx : CARDINAL) ; FORWARD ; PROCEDURE ParseCallArgs (idx : CARDINAL) ; FORWARD ; PROCEDURE EmCallMost (idx, nk : CARDINAL) ; FORWARD ; (* ---------------------------------------------------------------- *) (* expressions (TPSRC9) *) (* ---------------------------------------------------------------- *) PROCEDURE LoadAtom (VAR r : ERes) ; (* load value of r into AX (folding constants). A string literal is refused here, and this is the single place that has to: assignment, IF, WHILE, FOR, REPEAT, CASE, array subscripts and every operator all reach their operand through LoadAtom, and none of them can use a counted string where a 16-bit word is expected. Reporting it here rather than in the parser means writeln('hi') still works - IoCall handles a literal before it ever calls LoadAtom. *) BEGIN IF r.cls = TString THEN Err (ENoLib) ; (* string value used as a number *) r.kind := 2 ; RETURN END ; IF r.kind = 0 THEN EmMovAxi (W16 (r.imm)) ; r.kind := 2 ELSIF r.kind = 1 THEN IF symtab [r.idx].size > 2 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 EmXchgAxDx () ; (* 92h = XCHG AX,DX. Named for what it EMITS, which is the point of the whole naming convention: this used to be called EmMoveAxDx, which is what somebody would expect the opcode to be, and it is not - 89 D8 is MOV AX,DX, 92h is the exchange. Here the exchange is what is wanted, so the name is the only thing that was wrong, and it was wrong in the exact way this file's names are not allowed to be: reading as "a move" when it is a swap. After EmIDivAxCx the remainder is in DX and `mod` wants it in AX; an exchange gets it there in one byte where a move also would, so the behaviour is identical either way and only the name lied. *) BEGIN Ebyte (92H) END EmXchgAxDx ; PROCEDURE 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 OpAdd : f := ConstAdd (left.imm, right.imm) ; okc := TRUE ; | OpSub : f := ConstSub (left.imm, right.imm) ; okc := TRUE ; | OpMul : f := ConstMul (left.imm, right.imm) ; okc := TRUE ; | TkDiv : okc := (right.imm # 0) AND (right.imm > 0) AND (left.imm >= 0) ; IF okc THEN f := left.imm DIV right.imm END ; | TkMod : okc := (right.imm # 0) AND (right.imm > 0) AND (left.imm >= 0) ; IF okc THEN f := left.imm MOD right.imm END ; ELSE okc := FALSE END ; IF okc THEN res.kind := 0 ; res.imm := VAL (LONGINT, W16 (f)) ; res.cls := left.cls ; RETURN ELSIF op = TkDiv THEN Err (EConstRange) ; RETURN END END ; LoadAtom (left) ; EmPushAx () ; LoadAtom (right) ; EmPopCx () ; EmXchgAxCx () ; CASE op OF OpAdd : EmAddAxCx ; | OpSub : EmSubAxCx ; | OpMul : EmMulAxCx ; | TkDiv : EmIDivAxCx ; | TkMod : EmIDivAxCx ; EmXchgAxDx ; ELSE Err (ETypeErr) END ; res.kind := 2 ; res.cls := left.cls END BinOpEmit ; PROCEDURE ConstCmp (op : CARDINAL ; a, b : LONGINT ; VAR f : LONGINT) : BOOLEAN ; VAR a16, b16 : CARDINAL ; BEGIN a16 := W16 (a) ; b16 := W16 (b) ; f := 0 ; CASE op OF 1 : f := VAL (LONGINT, ORD (a16 = b16)) ; | 2 : f := VAL (LONGINT, ORD (a16 # b16)) ; | 3 : f := VAL (LONGINT, ORD (a16 < b16)) ; | 4 : f := VAL (LONGINT, ORD (a16 >= b16)) ; | 5 : f := VAL (LONGINT, ORD (a16 > b16)) ; | 6 : f := VAL (LONGINT, ORD (a16 <= b16)) ; ELSE RETURN FALSE END ; RETURN TRUE END ConstCmp ; 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 () ; (* The mnemonic is written next to every opcode on purpose. `op' is a number, so the arm for ">" and the arm for ">=" differed only by two hex digits that are each one letter from the other meaning -- SETG (9FH) and SETGE (9DH). They were swapped, which made a > b mean a >= b and a >= b mean a > b. Only the equality boundary could see it: 6>5, 5<5, -1>-2 and every other case I tried were already right. An opcode on its own does not say which comparison it is the answer to. *) CASE op OF 1 : EmSetcc (94H) ; (* = SETE *) | 2 : EmSetcc (95H) ; (* <> SETNE *) | 3 : EmSetcc (9CH) ; (* < SETL *) | 4 : EmSetcc (9FH) ; (* > SETG *) | 5 : EmSetcc (9DH) ; (* >= SETGE *) | 6 : EmSetcc (9EH) (* <= SETLE *) END ; r.kind := 2 ; r.cls := TBool END END END ParseCmp ; PROCEDURE ParseAdd (VAR r : ERes) ; VAR op : CARDINAL ; left, right : ERes ; BEGIN ParseMul (r) ; LOOP op := 0 ; Skip () ; IF CurCh () = '+' THEN op := OpAdd ; DropCh (GetCh ()) ELSIF CurCh () = '-' THEN op := OpSub ; DropCh (GetCh ()) ELSIF KwAhead ("OR") THEN GetWord () ; op := TkOr ELSE RETURN END ; left := r ; ParseMul (right) ; BinOpEmit (op, left, right, r) END END ParseAdd ; PROCEDURE ParseMul (VAR r : ERes) ; VAR op : CARDINAL ; left, right : ERes ; BEGIN ParseNeg (r) ; LOOP op := 0 ; Skip () ; IF CurCh () = '*' THEN op := OpMul ; DropCh (GetCh ()) (* OpAdd here meant a*b -> a+b *) ELSIF CurCh () = '/' THEN op := 2 ; DropCh (GetCh ()) ; Err (ENoLib) ELSIF KwAhead ("DIV") THEN GetWord () ; op := TkDiv ELSIF KwAhead ("MOD") THEN GetWord () ; op := TkMod ELSIF KwAhead ("AND") THEN GetWord () ; op := TkAnd ELSE RETURN END ; IF op = 2 THEN RETURN END ; left := r ; ParseNeg (right) ; BinOpEmit (op, left, right, r) END END ParseMul ; PROCEDURE ParseNeg (VAR r : ERes) ; BEGIN Skip () ; IF CurCh () = '+' THEN DropCh (GetCh ()) ; ParseNeg (r) ; RETURN ELSIF CurCh () = '-' THEN DropCh (GetCh ()) ; ParseNeg (r) ; IF r.kind = 0 THEN r.imm := VAL (LONGINT, W16 (0 - r.imm)) ELSE LoadAtom (r) ; EmNegAx () ; r.kind := 2 END ; RETURN ELSIF KwAhead ("NOT") THEN GetWord () ; ParseNeg (r) ; IF r.kind = 0 THEN r.imm := BitNot (r.imm) ELSE LoadAtom (r) ; EmNotAx () ; r.kind := 2 END ; RETURN END ; ParseAtom (r) END ParseNeg ; PROCEDURE ParseAtom (VAR r : ERes) ; (* const | variable | func(params) | '(' expr ')' *) VAR idx : CARDINAL ; strf : BOOLEAN ; quoted : BOOLEAN ; BEGIN r.chr := FALSE ; (* default: not a quoted char literal *) Skip () ; IF CurCh () = '(' THEN DropCh (GetCh ()) ; ParseExpr (r) ; ExpectDelim (')', ENoSemi) ; RETURN END ; IF (CurCh () = '$') OR (Digit (CurCh ())) OR (ORD (CurCh ()) = AposC) THEN (* remember that this was a quoted literal BEFORE RdConst consumes it: RdConst reports a 1-character literal as TScalar (its char code), which is right for "c := 'a'" but would make writeln('a') print 97. Mark it so the writer picks the char entry, not the integer one. *) quoted := (ORD (CurCh ()) = AposC) ; RdConst (r.imm, r.cls, strf) ; r.chr := quoted AND (r.cls = TScalar) AND NOT strf ; IF r.cls = TReal THEN Err (ENoLib) ; r.kind := 2 ; RETURN END ; IF strf THEN (* A string literal is legal here as a *value* - it is not rejected at this point, because writeln('hi') needs it and IoCall is the only place that knows how to emit one. Everywhere else the literal has to end up as a machine word, and that is caught by LoadAtom, which refuses a TString. *) r.strx := rdStrX ; r.kind := 3 ; RETURN END ; r.kind := 0 ; RETURN END ; IF NOT Alpha (CurCh ()) THEN Err (EUnknown) ; RETURN END ; GetWord () ; IF NOT Search (wrd, idx) THEN Err (EUnknown) ; RETURN END ; IF symtab [idx].tag = KConst THEN r.kind := 0 ; r.imm := symtab [idx].lval ; r.cls := symtab [idx].cls ; RETURN ELSIF symtab [idx].tag = KFunc THEN ParseCall (idx) ; r.kind := 2 ; r.cls := symtab [idx].cls ; RETURN ELSIF (symtab [idx].tag = KVar) OR (symtab [idx].tag = KType) THEN ParseVar (r) ; r.boff := 0 ; RETURN ELSE Err (EUnknown) END END ParseAtom ; PROCEDURE AddPend (kind, who, place : CARDINAL) ; BEGIN IF nPend < MaxPend THEN pend [nPend].kind := kind ; pend [nPend].who := who ; pend [nPend].place := place ; INC (nPend) ELSE Err (ECompOvf) END END AddPend ; PROCEDURE EmCallMost (idx, nk : CARDINAL) ; (* emit the call to sym 'idx' and clean up nk value arguments *) VAR p : CARDINAL ; BEGIN IF symtab [idx].defnd THEN DropC (EmCall (symtab [idx].goPos)) ELSE p := EmCall (0) ; AddPend (1, idx, p) END ; IF nk > 0 THEN EmAddSp (2 * nk) END END EmCallMost ; PROCEDURE ParseCallArgs (idx : CARDINAL) ; (* '(' already consumed: read args ')' then call. Arguments are pushed right-to-left so the first-declared parameter lands at BP+4. *) VAR args : ARRAY [0..15] OF ERes ; nArgs, i : CARDINAL ; BEGIN nArgs := 0 ; IF CurCh () = ')' THEN DropCh (GetCh ()) ELSE LOOP IF nArgs >= 16 THEN Err (ECompOvf) ; EXIT END ; ParseExpr (args [nArgs]) ; INC (nArgs) ; IF NOT MatchDelim (',') THEN EXIT END END ; ExpectDelim (')', ENoSemi) END ; i := nArgs ; WHILE i > 0 DO DEC (i) ; LoadAtom (args [i]) ; EmPushAx () END ; EmCallMost (idx, nArgs) END ParseCallArgs ; PROCEDURE ParseCall (idx : CARDINAL) ; (* procedure/function call; '(' optional *) VAR args : ARRAY [0..15] OF ERes ; nArgs, i : CARDINAL ; BEGIN nArgs := 0 ; IF MatchDelim ('(') THEN IF CurCh () # ')' THEN LOOP IF nArgs >= 16 THEN Err (ECompOvf) ; EXIT END ; ParseExpr (args [nArgs]) ; INC (nArgs) ; IF NOT MatchDelim (',') THEN EXIT END END ; ExpectDelim (')', ENoSemi) ELSE DropCh (GetCh ()) END END ; i := nArgs ; WHILE i > 0 DO DEC (i) ; LoadAtom (args [i]) ; EmPushAx () END ; EmCallMost (idx, nArgs) END ParseCall ; PROCEDURE ParseExpr (VAR r : ERes) ; BEGIN ParseCmp (r) END ParseExpr ; (* ---------------------------------------------------------------- *) (* statements (TPSRC8) *) (* ---------------------------------------------------------------- *) PROCEDURE ParseLabelStmt () ; (* numeric label definition 'n :' *) VAR n : CARDINAL ; nm : ARRAY [0..9] OF CHAR ; idx : CARDINAL ; i : CARDINAL ; BEGIN n := 0 ; WHILE Digit (CurCh ()) DO n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ; DropCh (GetCh ()) END ; ExpectDelim (':', ENoSemi) ; NumToName (n, nm) ; IF Search (nm, idx) THEN IF symtab [idx].tag = KLabel THEN symtab [idx].defnd := TRUE ; symtab [idx].goPos := pc ; i := 0 ; WHILE i < nPend DO IF (pend [i].kind = 0) AND (pend [i].who = idx) THEN SetPatTgt (pend [i].place, pc) ; pend [i].kind := 99 END ; INC (i) END ELSE Err (EUnknown) END ELSE idx := NewSym (nm, KLabel, TScalar, 0, 0, 0, 0, FALSE) ; symtab [idx].defnd := TRUE ; symtab [idx].goPos := pc END END ParseLabelStmt ; PROCEDURE Assignment (r : ERes) ; (* ':=' already consumed by the caller; store expression into r *) VAR src : ERes ; BEGIN IF r.kind # 1 THEN Err (EUnknown) ; RETURN END ; IF symtab [r.idx].size > 2 THEN Err (ENoLib) ; RETURN END ; ParseExpr (src) ; LoadAtom (src) ; EmStoreVar (symtab [r.idx].local, (symtab [r.idx].off + r.boff) MOD 10000H, symtab [r.idx].size) END Assignment ; PROCEDURE Compound () ; (* BEGIN statement ';' ... END; END is consumed here *) VAR tok : CARDINAL ; BEGIN LOOP PeekKw (tok) ; IF tok = TkEnd THEN DropB (MatchKey (tok)) ; RETURN END ; Statmnt () ; IF NOT OK () THEN RETURN END ; IF NOT MatchDelim (';') THEN PeekKw (tok) ; IF tok = TkEnd THEN DropB (MatchKey (tok)) ; RETURN END ; Err (ENoSemi) ; RETURN END END END Compound ; PROCEDURE IoCall (idx : CARDINAL) ; (* WRITE / WRITELN / READ / READLN / HALT. TP3 (TPSRC8 pwriteln, pwrloop, prdtyped) does not pass a descriptor to the runtime: it looks at each argument's class and emits a *different* call per type, so the formatting is fixed at compile time. Mirrored here - one call per argument, then a final call for the line break. WRITE/WRITELN push the value; READ/READLN push the address, so the runtime can store. As everywhere else in this compiler the caller cleans the argument off the stack. *) VAR args : ARRAY [0..15] OF ERes ; nArgs, i, ent, which, acls : CARDINAL ; reading : BOOLEAN ; pushed : BOOLEAN ; n : CARDINAL ; dummy : ERes ; BEGIN which := symtab [idx].cls ; (* BI_* *) IF which = BI_Halt THEN IF MatchDelim ('(') THEN (* halt(0) - code ignored *) ParseExpr (dummy) ; ExpectDelim (')', ENoSemi) END ; DropC (EmCall (TU_Halt)) ; RETURN END ; reading := (which = BI_Read) OR (which = BI_ReadLn) ; nArgs := 0 ; IF MatchDelim ('(') THEN IF CurCh () # ')' THEN LOOP IF nArgs >= 16 THEN Err (ECompOvf) ; EXIT END ; ParseExpr (args [nArgs]) ; INC (nArgs) ; IF NOT MatchDelim (',') THEN EXIT END END ; IF NOT MatchDelim (')') THEN Err (ENoSemi) ; RETURN END ELSE DropCh (GetCh ()) END END ; IF reading AND (nArgs = 0) THEN (* readln with no variable: just skip to the next line *) DropC (EmCall (TU_RdLn)) ; RETURN END ; (* NB: guard the loop bound - with nArgs = 0, "nArgs - 1" would wrap round to 65535 in CARDINAL and spin 65536 times. *) IF nArgs > 0 THEN FOR i := 0 TO nArgs - 1 DO pushed := TRUE ; (* default: value is on the stack -> call + pop *) IF reading THEN IF args [i].kind # 1 THEN Err (ETypeErr) ; (* READ needs a variable *) RETURN END ; acls := symtab [args [i].idx].cls ; IF acls = TString THEN Err (ENoLib) ; (* string runtime pending *) RETURN END ; EmPushVarAddr (symtab [args [i].idx].local, symtab [args [i].idx].off) ; IF acls = TReal THEN ent := TU_RdInt (* real reads: not yet *) ELSIF acls = TBool THEN ent := TU_RdBool ELSIF acls = TChar THEN ent := TU_RdChar (* one byte, not a word *) ELSIF acls = TScalar THEN ent := TU_RdInt ELSE Err (ETypeErr) ; RETURN END ELSE acls := args [i].cls ; IF (acls = TString) AND (args [i].kind = 3) THEN (* An inline string literal. TP3 TPSRC8 pwrinlin special-cases a literal that is followed directly by ',' or ')' - i.e. an argument, not an expression - and emits CALL wrtinl with no stack argument at all; wrtinl reads the length from the return address and returns to just past the last character. Mirrored exactly, so the literal costs only its own characters in the code stream and nothing in the data segment. *) IF strLen [args [i].strx] > 255 THEN (* The length is one byte, so a literal of 256 characters or more would wrap: 300 characters emitted behind a length of 44, and the runtime would print 44 of them and silently drop the rest. TP3 strings are at most 255 characters, so refuse rather than truncate. *) Err (EConstRange) ; RETURN END ; DropC (EmCall (TU_WrInl)) ; Ebyte (VAL (BYTE, strLen [args [i].strx])) ; n := 0 ; WHILE n < strLen [args [i].strx] DO Ebyte (VAL (BYTE, ORD (strPool [strOff [args [i].strx] + n]))) ; INC (n) END ; pushed := FALSE (* nothing was pushed for this one *) ELSE IF acls = TString THEN (* A string *variable*. Not emitted rather than emitted wrongly: EmPushVarAddr's local form is still wrong (see the note on that procedure), and a wrong address here would print garbage instead of failing. *) Err (ENoLib) ; RETURN END ; LoadAtom (args [i]) ; EmPushAx () ; IF args [i].chr THEN ent := TU_WrChar (* 'a' - one char, not 97 *) ELSIF acls = TReal THEN ent := TU_WrReal ELSIF acls = TBool THEN ent := TU_WrBool ELSIF acls = TChar THEN ent := TU_WrChar (* c : char - one char *) ELSIF acls = TScalar THEN ent := TU_WrInt ELSE Err (ETypeErr) ; RETURN END END END ; IF pushed THEN DropC (EmCall (ent)) ; EmAddSp (2) (* one 16-bit argument *) END END END ; IF which = BI_WriteLn THEN DropC (EmCall (TU_WrLn)) ELSIF which = BI_ReadLn THEN DropC (EmCall (TU_RdLn)) END END IoCall ; PROCEDURE Statmnt () ; VAR tok : CARDINAL ; idx, i2 : CARDINAL ; t, src : ERes ; L1, zj, zj2, exj : CARDINAL ; lo, hi, v : LONGINT ; clso : CARDINAL ; i : CARDINAL ; nm : ARRAY [0..MaxName] OF CHAR ; strf : BOOLEAN ; dow : BOOLEAN ; BEGIN Skip () ; IF Digit (CurCh ()) THEN ParseLabelStmt () ; (* consumed 'n' ':' *) Statmnt () ; (* 'n : statement' - the statement follows the label directly, with no ';' between *) RETURN END ; IF NOT Alpha (CurCh ()) THEN ExpectDelim (';', ENoSemi) ; RETURN END ; DropB (MatchKey (tok)) ; IF tok = TkBegin THEN Compound () ELSIF tok = TkIf THEN ParseExpr (t) ; LoadAtom (t) ; EmCmpAxi (0) ; zj := EmJcc (84H, 0) ; (* JZ -> else/end *) IF NOT (MatchKey (tok) AND (tok = TkThen)) THEN Err (ENoSemi) END ; Statmnt () ; (* Peek the ELSE, do not match it. `MatchKey (tok) AND (tok = TkElse)` consumes whatever the next keyword is even when the AND fails, so an `if` that was the LAST statement of a BEGIN..END block ate the block's own END: Compound then found neither ';' nor END and raised ENoSemi. Any `if` as the last statement of a compound was unparseable - not in a loop, not anywhere - and no fixture had one, so nothing noticed. The visible symptom was a parse error at the statement AFTER the block, which points at entirely the wrong piece of source. *) PeekKw (tok) ; IF tok = TkElse THEN DropB (MatchKey (tok)) ; exj := EmJmpNear (0) ; SetPatTgt (zj, pc) ; Statmnt () ; SetPatTgt (exj, pc) ELSE SetPatTgt (zj, pc) END ELSIF tok = TkWhile THEN L1 := pc ; ParseExpr (t) ; LoadAtom (t) ; EmCmpAxi (0) ; zj := EmJcc (84H, 0) ; (* JZ -> end *) IF NOT (MatchKey (tok) AND (tok = TkDo)) THEN Err (ENoSemi) END ; brkSave [brkN] := exitCnt ; loopTy [brkN] := 1 ; INC (brkN) ; Statmnt () ; DEC (brkN) ; i := brkSave [brkN] ; WHILE i < exitCnt DO SetPatTgt (exitPatch [i], pc) ; INC (i) END ; exitCnt := brkSave [brkN] ; DropC (EmJmpNear (L1)) ; SetPatTgt (zj, pc) ELSIF tok = TkRepeat THEN L1 := pc ; brkSave [brkN] := exitCnt ; loopTy [brkN] := 1 ; INC (brkN) ; Statmnt () ; IF NOT (MatchKey (tok) AND (tok = TkUntil)) THEN Err (ENoSemi) END ; ParseExpr (t) ; LoadAtom (t) ; EmCmpAxi (0) ; (* UNTIL exits when the condition is TRUE, so the body runs again when it is FALSE. The condition is a 0/1 in AX and EmCmpAxi (0) has just compared it with 0, so ZF=1 means "condition false" -- which is exactly the case that loops, hence JZ. This was JNZ, which compiled repeat-until as while-until: the body ran once, the condition was tested, and it stopped. t12_repeat is `i:=0; repeat i:=i+1 until i>5' and it printed 1. No patch slot: L1 is backwards and already known, so EmJcc returns 0 and there is nothing to SetPatTgt. *) DropC (EmJcc (84H, L1)) ; (* JZ -> body again *) DEC (brkN) ; i := brkSave [brkN] ; WHILE i < exitCnt DO SetPatTgt (exitPatch [i], pc) ; INC (i) END ; exitCnt := brkSave [brkN] ELSIF tok = TkFor THEN (* control variable *) Skip () ; (* after the FOR keyword: skip blanks *) IF NOT Alpha (CurCh ()) THEN Err (EUnknown) ; RETURN END ; GetWord () ; IF NOT Search (wrd, idx) THEN Err (EUnknown) ; RETURN END ; IF symtab [idx].size > 2 THEN Err (ENoLib) ; RETURN END ; IF NOT MatchAssign () THEN Err (ENoSemi) END ; ParseExpr (src) ; LoadAtom (src) ; EmStoreVar (symtab [idx].local, symtab [idx].off, symtab [idx].size) ; IF NOT MatchKey (tok) THEN Err (ESimpType) ; RETURN END ; IF (tok = TkTo) OR (tok = TkDownto) THEN dow := (tok = TkDownto) ELSE Err (ESimpType) ; RETURN END ; ParseExpr (t) ; LoadAtom (t) ; EmPushAx () ; (* loop bound on the stack *) IF NOT (MatchKey (tok) AND (tok = TkDo)) THEN Err (ENoSemi) END ; brkSave [brkN] := exitCnt ; loopTy [brkN] := 2 ; INC (brkN) ; L1 := pc ; (* Ltest: the test comes FIRST *) (* The test is emitted before the body, not after it. It used to be emitted after, which is a post-test loop and runs the body one time too many: with `for i := 1 to 5`, the sequence of i at the test is 1,2,3,4,5,6 - the test at i=5 is `5 > 5`, which is false, so the body ran a sixth time with i=6. `for i := 1 to 5 do s := s + i` printed 21. The size was right and the shape was right; only the order was wrong, and no byte check can see an order. The bound stays on the stack for the whole loop, so EmMovCxSp has to re-read it every iteration - which is also what makes the bound a *variable* rather than a constant. [SP] cannot be encoded on the 8086, so EmMovCxSp is POP CX ; PUSH CX, an observational no-op that leaves the bound in place. *) EmMovCxSp () ; EmLoadVar (symtab [idx].local, symtab [idx].off, symtab [idx].size) ; EmCmpAxCx () ; IF dow THEN zj := EmJcc (8CH, 0) (* JL -> done *) ELSE zj := EmJcc (8FH, 0) (* JG -> done *) END ; Statmnt () ; DEC (brkN) ; (* A FOR's exits are NOT patched here, even though `done` is not known yet. For a WHILE or REPEAT, "just after the body" is a correct target: the jump back to the test re-evaluates the condition and leaves. For a FOR there is a STEP between the body and `done`, so an EXIT that jumped here would increment the control variable and jump back to the test - and if the incremented value still satisfied the bound, it would run the body AGAIN. `exit` did not exit. The fix needs no new bookkeeping: `brkSave [brkN] .. exitCnt` still names exactly this loop's exits, because Statmnt may have added more and nothing has reset exitCnt. So they are patched at `done`, below. A WHILE nested inside the FOR saves and restores its own range and leaves this one intact. *) (* step *) EmLoadVar (symtab [idx].local, symtab [idx].off, symtab [idx].size) ; IF dow THEN EmDecAx () ELSE EmIncAx () END ; EmStoreVar (symtab [idx].local, symtab [idx].off, symtab [idx].size) ; DropC (EmJmpNear (L1)) ; SetPatTgt (zj, pc) ; (* done: *) (* A WHILE loop here, not a FOR over the exit range. The range is usually EMPTY - most loops have no `exit` - and `exitCnt` is a CARDINAL, so `TO exitCnt - 1` with exitCnt = 0 is `TO 65535`: the loop does not terminate, it wraps, and it walks exitPatch [0..65535] off the end of a 64-element array. `for i := 1 to 10 do i := i` has no exit, so this is the ORDINARY case, and it faulted with "invalid address referenced" on every FOR loop without an exit. *) i := brkSave [brkN] ; WHILE i < exitCnt DO SetPatTgt (exitPatch [i], pc) ; INC (i) END ; exitCnt := brkSave [brkN] ; EmAddSp (2) (* drop the loop bound *) ELSIF tok = TkCase THEN ParseExpr (t) ; LoadAtom (t) ; EmPushAx () ; (* selector on the stack *) IF NOT (MatchKey (tok) AND (tok = TkOf)) THEN Err (ENoSemi) END ; caseN := 0 ; LOOP Skip () ; IF MatchDelim (';') THEN Skip () END ; PeekKw (tok) ; IF (tok = TkEnd) OR (tok = TkElse) THEN EXIT END ; (* case label : constant identifier or literal *) IF Alpha (CurCh ()) THEN GetWord () ; IF Search (wrd, i2) AND (symtab [i2].tag = KConst) THEN lo := symtab [i2].lval ELSE Err (EUnknown) ; EXIT END ELSE RdConst (lo, clso, strf) END ; IF MatchRange () THEN RdConst (hi, clso, strf) ELSE hi := lo END ; ExpectDelim (':', ENoSemi) ; EmMovAxSp () ; EmCmpAxi (W16 (lo)) ; zj := EmJcc (85H, 0) ; (* JNZ -> next *) IF hi # lo THEN EmCmpAxi (W16 (hi)) ; zj2 := EmJcc (85H, 0) ELSE zj2 := 0 END ; Statmnt () ; IF caseN >= 64 THEN Err (ECompOvf) ; EXIT END ; caseJmp [caseN] := EmJmpNear (0) ; INC (caseN) ; SetPatTgt (zj, pc) ; IF zj2 # 0 THEN SetPatTgt (zj2, pc) END END ; IF tok = TkElse THEN DropB (MatchKey (tok)) ; Statmnt () ; IF NOT (MatchKey (tok) AND (tok = TkEnd)) THEN Err (ENoSemi) END ELSE DropB (MatchKey (tok)) END ; EmAddSp (2) ; FOR i := 0 TO caseN - 1 DO SetPatTgt (caseJmp [i], pc) END ELSIF tok = TkGoto THEN v := 0 ; Skip () ; (* after the GOTO keyword: skip blanks *) IF Digit (CurCh ()) THEN RdIntConst (v) ; NumToName (W16 (v), nm) ; IF Search (nm, idx) THEN IF symtab [idx].tag = KLabel THEN IF symtab [idx].defnd THEN DropC (EmJmpNear (symtab [idx].goPos)) ELSE zj := EmJmpNear (0) ; AddPend (0, idx, zj) END ELSE Err (EUnknown) END ELSE idx := NewSym (nm, KLabel, TScalar, 0, 0, 0, 0, FALSE) ; zj := EmJmpNear (0) ; AddPend (0, idx, zj) END ELSE Err (EUnknown) END ELSIF tok = TkExit THEN IF brkN = 0 THEN Err (EUnknown) ELSE (* No EmAddSp (2) here, even inside a FOR. The FOR's `done` label drops the bound, so an EXIT that jumped to `done` would drop it a second time - 4 bytes off a stack that only had 2 to give, which silently corrupts the caller's frame. It used to do exactly that, and it was doubly wrong: the exits were patched to the STEP rather than to `done`, so the EXIT also incremented the control variable and jumped back into the test. *) zj := EmJmpNear (0) ; IF exitCnt < 64 THEN exitPatch [exitCnt] := zj ; INC (exitCnt) END END ELSIF tok = TkWith THEN Err (ENoLib) ELSE (* identifier statement: assignment or call *) IF NOT Search (wrd, idx) THEN Err (EUnknown) ; RETURN END ; IF symtab [idx].tag = KBuiltin THEN IoCall (idx) ; RETURN END ; IF symtab [idx].tag = KProc THEN IF MatchDelim ('(') THEN ParseCallArgs (idx) ELSE ParseCall (idx) END ; RETURN END ; IF (symtab [idx].tag = KVar) OR (symtab [idx].tag = KFunc) THEN t.idx := idx ; t.kind := 1 ; t.boff := 0 ; t.cls := symtab [idx].cls ; IF symtab [idx].tag = KFunc THEN t.idx := symtab [idx].resvar ; t.cls := symtab [t.idx].cls END ; ParseSub (t) ; IF MatchAssign () THEN Assignment (t) ; RETURN END ; Err (ENoSemi) ; RETURN END ; Err (ENoSemi) END END Statmnt ; (* ---------------------------------------------------------------- *) (* types and declarations (TPSRC7) *) (* ---------------------------------------------------------------- *) PROCEDURE ParseType (VAR cls, size, elem : CARDINAL) ; VAR tok : CARDINAL ; idx : CARDINAL ; lo, hi : LONGINT ; s2, e2 : CARDINAL ; subcls : CARDINAL ; strf : BOOLEAN ; consumed : BOOLEAN ; BEGIN cls := TNone ; size := 0 ; elem := 0 ; consumed := FALSE ; Skip () ; (* after ':' / '=' : skip blanks *) IF Alpha (CurCh ()) THEN DropB (MatchKey (tok)) ; consumed := TRUE ELSE tok := TkNone END ; IF tok = TkArray THEN ExpectDelim ('[', ENoSemi) ; RdConst (lo, subcls, strf) ; IF NOT MatchRange () THEN Err (ESimpType) END ; RdConst (hi, subcls, strf) ; ExpectDelim (']', ENoSemi) ; IF NOT (MatchKey (tok) AND (tok = TkOf)) THEN Err (ENoSemi) END ; ParseType (cls, s2, e2) ; cls := TArray ; elem := s2 ; size := s2 * (W16 (VAL (LONGINT, W16 (hi)) - VAL (LONGINT, W16 (lo)) + 1)) ELSIF tok = TkString THEN cls := TString ; size := 256 ; elem := 1 ; IF MatchDelim ('[') THEN RdConst (hi, subcls, strf) ; ExpectDelim (']', ENoSemi) ; size := W16 (hi) + 1 END ELSIF tok = TkSet THEN Err (ENoLib) ; (* Unreachable, and it would be wrong even if it were reached: a speculative `MatchKey (tok) AND (tok = TkOf)` consumes the token it rejects. See the note in the IF handler. *) IF MatchKey (tok) AND (tok = TkOf) THEN ParseType (cls, s2, e2) END ELSIF tok = TkRecord THEN Err (ENoLib) ; LOOP PeekKw (tok) ; IF tok = TkEnd THEN DropB (MatchKey (tok)) ; EXIT END ; IF CurCh () = 0C THEN EXIT END ; Skip () ; IF Alpha (CurCh ()) THEN DropCh (GetCh ()) ELSE DropCh (GetCh ()) END END ELSIF (tok = TkFile) OR (tok = TkText) THEN cls := TFile ; size := 0 ; elem := 0 ; Err (ENoLib) ELSE IF consumed THEN IF Search (wrd, idx) AND (symtab [idx].tag = KType) THEN cls := symtab [idx].cls ; size := symtab [idx].size ; elem := symtab [idx].size ELSE Err (EUnknown) END ELSE (* subrange lo .. hi *) RdConst (lo, subcls, strf) ; IF NOT MatchRange () THEN Err (ESimpType) ; RETURN END ; RdConst (hi, subcls, strf) ; cls := TScalar ; size := 2 ; elem := 2 END END END ParseType ; PROCEDURE DefVar () ; (* 'name' (',' name)* ':' type [ABSOLUTE addr] ; group repeated until a declaration keyword appears *) VAR nm : ARRAY [0..MaxName] OF CHAR ; cls, size, elem : CARDINAL ; tok : CARDINAL ; v : LONGINT ; off : CARDINAL ; 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 ; nestMark : CARDINAL ; (* symTop just inside this procedure *) 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) ; nestMark := symTop ; (* after the proc's own name, before its params *) 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 () ; HideLocals (nestMark) ; (* a FORWARD's parameters are not the caller's to see either *) lexnest := saveNest ; locFree := saveLoc ; resultVar := saveRes ; curIsFunc := (saveF # 0) ; locBytes := saveLB ; parmOff := savePO ; RETURN END ; (* body *) symtab [old].goPos := pc ; symtab [old].defnd := TRUE ; EmPushBp () ; EmMovBpSp () ; DefPart () ; (* nested declarations; stops at BEGIN *) IF locBytes > 0 THEN EmSubSp (locBytes) END ; DropC (EmCall (TU_StackChk)) ; Statmnt () ; (* body *) IF OK () THEN SymEpi () ; EmLeave () ; EmRet () END ; (* patch pending forward calls to this proc *) i := 0 ; WHILE i < nPend DO IF (pend [i].kind = 1) AND (pend [i].who = old) THEN SetPatTgt (pend [i].place, symtab [old].goPos) ; pend [i].kind := 99 END ; INC (i) END ; HideLocals (nestMark) ; (* parameters and locals stop here *) lexnest := saveNest ; locFree := saveLoc ; resultVar := saveRes ; curIsFunc := (saveF # 0) ; locBytes := saveLB ; parmOff := savePO END ProcFunc ; PROCEDURE DefType () ; (* 'name' '=' typeDef ; ... until a declaration keyword appears *) VAR nm : ARRAY [0..MaxName] OF CHAR ; cls, size, elem : CARDINAL ; tok : CARDINAL ; BEGIN LOOP PeekKw (tok) ; IF tok # TkNone THEN RETURN END ; Skip () ; (* after the TYPE keyword: skip blanks *) IF NOT Alpha (CurCh ()) THEN Err (EUnknown) ; RETURN END ; GetWord () ; SaveWord (nm) ; DupTest (nm) ; ExpectDelim ('=', ENoSemi) ; ParseType (cls, size, elem) ; IF NOT OK () THEN RETURN END ; DropC (NewSym (nm, KType, cls, size, elem, 0, 0, FALSE)) ; IF NOT MatchDelim (';') THEN Err (ENoSemi) ; RETURN END END END DefType ; PROCEDURE DefPart () ; (* LABEL / CONST / TYPE / VAR / OVERLAY / PROC / FUNCTION / BEGIN *) VAR tok : CARDINAL ; BEGIN LOOP IF MatchDelim (';') THEN (* separator between declarations *) ELSE PeekKw (tok) ; IF tok = TkBegin THEN RETURN END ; IF NOT MatchKey (tok) THEN Err (EUnknown) ; RETURN END ; CASE tok OF TkLabel : DefLabelPart () ; | TkConst : DefConst () ; | TkType : DefType () ; | TkVar : DefVar () ; | TkOverlay : LOOP Skip () ; IF CurCh () = ';' THEN DropCh (GetCh ()) ; EXIT END ; IF CurCh () = 0C THEN Err (ENoSemi) ; EXIT END ; DropCh (GetCh ()) END ; | TkProcedure : curIsFunc := FALSE ; ProcFunc () ; | TkFunction : curIsFunc := TRUE ; ProcFunc () ; ELSE Err (EUnknown) ; RETURN END ; IF NOT OK () THEN RETURN END END END END DefPart ; (* ---------------------------------------------------------------- *) (* driver (TPSRC7 compile) *) (* ---------------------------------------------------------------- *) PROCEDURE DefBuiltins () ; (* The standard procedures. Without these, WRITELN is absent from the symbol table, Statmnt's identifier branch fails its Search and every program that prints anything dies with EUnknown (41) on the '(' after the call name - the single remaining cause of failure in the fixture matrix. Tagged KBuiltin (not KProc) because these are not called generically: WRITE/WRITELN/READ/READLN need TP3's per-argument type dispatch (IoCall), and HALT takes no argument at all. defnd is TRUE because the entry point is known - there is no forward reference to patch. *) VAR i : CARDINAL ; BEGIN i := NewSym ("WRITE" , KBuiltin, BI_Write , 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; symtab [i].goPos := TU_WrInt ; i := NewSym ("WRITELN", KBuiltin, BI_WriteLn, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; symtab [i].goPos := TU_WrInt ; i := NewSym ("READ" , KBuiltin, BI_Read , 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; symtab [i].goPos := TU_RdInt ; i := NewSym ("READLN" , KBuiltin, BI_ReadLn , 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; symtab [i].goPos := TU_RdInt ; i := NewSym ("HALT" , KBuiltin, BI_Halt , 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; symtab [i].goPos := TU_Halt END DefBuiltins ; PROCEDURE Inittur () ; (* reset compiler state and define the standard types *) VAR i, rt : CARDINAL ; BEGIN abortFac := FALSE ; errNum := 0 ; txerrPos := 0 ; srcPos := 0 ; srcLen := Length () ; (* The image layout is [JMP rel16][runtime][program header][program code] The runtime is copied to the front, which is what the original does: TPSRC7 "copyrt" runs REPZ MOVSB with SI=DI=0 and then "MOV pc,#$2D7C". Because the runtime sits at (near) offset 0, every address the compiler emits is already image-absolute - the data symbols' offsets, the TU_* call targets and the rel16 displacements all need no relocation pass. (The base shift would in fact cancel in EmCall's arithmetic, since both sides of a CALL move together; making the offsets absolute just means the linker has nothing to do but copy bytes.) The JMP is new, and it is not cosmetic. A DOS .COM is entered at CS:0100, i.e. FILE offset 0, and for a long time offset 0 held the runtime's first bytes - so a .COM built by this compiler started by executing initmem with AX holding whatever the loader left in it. Every test up to that point checked bytes and never ran the thing, so it could not see this. The jump is the program's entry and the runtime is ordinary data to it; keeping the runtime at the front is what preserves the no-relocation property, so the jump goes in front of the runtime rather than the runtime being moved behind the program. dc is put a fixed 4 KiB above the end of the program so that data cannot collide with code in a single 64 KiB .COM segment. LIMITATION: a program whose code exceeds 4 KiB overruns its own data area. TP3 had overlay segments for this; we do not, and the check belongs where the limit is documented rather than as a silent truncation. *) RT_Build (EntSize) ; rt := RT_Size () ; IF rt >= MaxCode THEN Err (EMemOvf) ; (* cannot happen: rt is 436 *) RETURN END ; (* The entry jump, at image offset 0. See the layout note above: a DOS .COM is entered at CS:0100, which is file offset 0, so whatever sits at offset 0 is the program's first executed instruction. *) (* The jump's three bytes are written out longhand rather than through Eword, because Eword writes at pc and advances it, and pc is stale at this point -- the operand landed wherever the last compile left pc. *) cbuf [0] := 0E9H ; (* JMP rel16 *) entRel := 1 ; cbuf [entRel] := 0 ; cbuf [entRel + 1] := 0 ; i := EntSize ; WHILE i - EntSize < rt DO cbuf [i] := RT_Byte (i - EntSize) ; INC (i) END ; pc := rt + EntSize ; rtSz := rt + EntSize ; dataBase := rtSz + 1000H ; dc := dataBase ; strTop := 0 ; strCnt := 0 ; rdStrX := 0 ; varspc := 0 ; symTop := 0 ; nPatch := 0 ; nPend := 0 ; exitCnt := 0 ; brkN := 0 ; caseN := 0 ; lexnest := 0 ; curIsFunc := FALSE ; resultVar := 0 ; locFree := 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, TChar, 1, 1, 0, 0, FALSE)) ; DropC (NewSym ("BOOLEAN", KType, TBool , 1, 1, 0, 0, FALSE)) ; DropC (NewSym ("REAL" , KType, TReal , 6, 6, 0, 0, FALSE)) ; DropC (NewSym ("STRING" , KType, TString, 256, 1, 0, 0, FALSE)) ; DropC (NewSym ("TRUE" , KConst, TBool, 1, 1, 0, 1, FALSE)) ; DropC (NewSym ("FALSE" , KConst, TBool, 1, 1, 0, 0, FALSE)) ; DefBuiltins () ; tmpA := NewSym ("@@T1", KVar, TScalar, 2, 2, dc, 0, FALSE) ; dc := dc + 2 ; tmpB := NewSym ("@@T2", KVar, TScalar, 2, 2, dc, 0, FALSE) ; dc := dc + 2 ; (* Runtime entry offsets, derived from the blob rather than assumed. This has to happen after RT_Build, since RT_Entry only knows where the code landed once the blob is assembled. RT_Entry returns an IMAGE-ABSOLUTE address, already biased by the base RT_Build was given, so nothing here has to know where the runtime landed. It used to return a blob-relative offset, and the bias was applied here instead - three bytes' worth, for the entry jump. With that line missing, every CALL landed three bytes short, in the middle of a neighbouring runtime entry, and a CALL into the middle of wrtin's `INT 21h' behaves perfectly plausibly: the program runs, prints nothing and hangs. Only running it finds that. *) IF (RT_Entry (13) = 0) OR (RT_Entry (11) = 0) OR (RT_Entry (3) = 0) THEN (* RT_Entry returns 0 for an unknown selector. initmem sits at 0 legitimately, so it cannot appear in this test - but wrtinl, rdln and wrint never can, so catching them is enough to catch a runtime that failed to build or a selector that went stale. This test is on 0 is not a usable address here, since RT_Entry returns an image-absolute address and the base is EntSize. *) Err (EMemOvf) END ; TU_InitMem := RT_Entry (0) ; TU_ProgEnd := RT_Entry (1) ; TU_StackChk := RT_Entry (2) ; TU_WrInt := RT_Entry (3) ; TU_WrChar := RT_Entry (4) ; TU_WrBool := RT_Entry (5) ; TU_WrReal := RT_Entry (6) ; TU_WrLn := RT_Entry (7) ; TU_RdInt := RT_Entry (8) ; TU_RdChar := RT_Entry (9) ; TU_RdBool := RT_Entry (10) ; TU_RdLn := RT_Entry (11) ; TU_Halt := RT_Entry (12) ; TU_WrInl := RT_Entry (13) ; (* inline string literal *) END Inittur ; PROCEDURE HeadWord (VAR slot : CARDINAL) ; BEGIN slot := pc ; Eword (0) END HeadWord ; PROCEDURE Compile (VAR errNo, errPos : CARDINAL) : BOOLEAN ; VAR tok : CARDINAL ; overProc : CARDINAL ; hasProc : BOOLEAN ; BEGIN Inittur () ; IF OK () THEN (* program prologue: header words, CALL initmem, MOV BP,SP *) HeadWord (hdrFlag) ; HeadWord (hdrCS) ; HeadWord (hdrDS) ; HeadWord (hdrHeap) ; HeadWord (hdrMax) ; Eword (16) ; (* max open files *) Eword (0) ; (* input buffer word *) Eword (0) ; (* output buffer word *) (* Here, and not one line earlier, is the first instruction of the program: everything above is the header, which is DATA. The entry jump has to land exactly here. Recorded rather than assumed, so that a header that grows a word moves the target with it. *) prologAt := pc ; (* TU_InitMem takes the header offset in AX, not on the stack, so the AX load has to precede the call. Previously the prologue called offset 8 - which in this layout is the hdrMax word - and that was coherent only because the runtime was not there. Now it is the real header. *) EmMovAxi ((rtSz + LoadBias) MOD 10000H) ; DropC (EmCall (TU_InitMem)) ; EmMovBpSp () ; IF MatchKey (tok) AND (tok = TkProgram) THEN (* MatchKey stops right after "PROGRAM", so the optional program name normally follows blanks. Skip them before testing for the name: otherwise Alpha sees the blank, the name is never consumed and IfMatchSemi reports ENoSemi at the name. *) Skip () ; IF Alpha (CurCh ()) THEN GetWord () END ; IF MatchDelim ('(') THEN WHILE NOT MatchDelim (')') DO IF Alpha (CurCh ()) THEN GetWord () END ; IF CurCh () = ',' THEN DropCh (GetCh ()) END END END ; IfMatchSemi () END ; IF OK () THEN (* Jump over the procedure bodies, if there are any. DefPart compiles them HERE, between the prologue and the main statement part, and there was no jump - so a program with a procedure fell off the end of the prologue into the first procedure. See DeclaresProc for why the condition is asked before DefPart runs and not after. *) hasProc := DeclaresProc () ; IF hasProc THEN overProc := EmJmpNear (0) END ; DefPart () ; IF OK () THEN (* A separate flag, NOT `overProc # 0`. EmJmpNear returns a patch SLOT, and slot 0 is a perfectly ordinary slot - the first forward jump in a program is slot 0. So a zero test cannot tell "no forward jump" from "forward jump in slot 0", it just skips the first patch, and the jump keeps its placeholder target of 0. The program then jumped to image offset 0, i.e. back to the entry jump, and ran the runtime and the whole program again, forever. The slot is only valid together with a boolean saying a slot was taken. *) IF hasProc THEN SetPatTgt (overProc, pc) END ; IF MatchKey (tok) AND (tok = TkBegin) THEN Compound () ; IF OK () THEN EmXorAxAx () ; DropC (EmCall (TU_ProgEnd)) ; ResolvePatches () ; (* Program-only sizes. The runtime is not part of the program's code, and the fixture table has always meant "the program's own code", so subtract it here rather than making every expectation in expected.tsv wrong. *) codeSz := pc - rtSz ; dataSz := dc - dataBase ; (* Header words. The layout is ours (the original's is bigger and serves a real overlay loader), but Runtime.EmitInitMem reads +4 and +8, so hdrDS and hdrHeap must be the data base and the data end. *) (* The entry jump's displacement. A .COM is entered at CS:0100 = file offset 0, so the jump is the only thing that decides where execution starts, and it has to land on the START of the program code - the prologue, which is at rtSz - not on pc, which is the END of it. (Patching pc - EntSize, i.e. the end, lands one byte past the last instruction, in the zero-filled code/data gap, where the CPU slides through `ADD [BX+SI],AL' until it faults.) The displacement is measured from the END of the jump, and both addresses are image-absolute, so the load segment cancels. *) (* The entry jump's displacement. A .COM is entered at CS:0100 = file offset 0, so this jump is the only thing that decides where execution starts. The target is prologAt - where the prologue ACTUALLY began, recorded before the header words were emitted, and the header is 16 bytes long, so this is rtSz + 16 and NOT rtSz. Landing on rtSz lands on the HEADER, which is data, and the CPU then decodes sixteen bytes of it as instructions. That failure is spectacularly non-deterministic across programs: 01 00 is `ADD [BX+SI],AX' and is harmless, so writeln('hi') ran fine by sliding through the header into the prologue, while t07's hdrHeap word 90 12 decodes as a LOCK-prefixed ADD whose displacement crosses a page and faults, and the program hung with no output at all. Both looked like "the jump is in the right area". Recording the position rather than assuming it means a future header that grows a word cannot silently reintroduce this. *) PatchWord (entRel, (prologAt - EntSize) MOD 10000H) ; PatchWord (hdrFlag, 1) ; (* Every OFFSET field in the header is a segment offset, i.e. an image offset plus LoadBias - one convention for the whole structure, so that nobody has to remember which of these five words is numbered which way. hdrFlag 1 set, so a loader can recognise the header hdrCS end of the generated code hdrDS first byte of the data area <- read by initmem hdrHeap one past the last <- read by initmem hdrMax 0 (no overlay loader yet) hdrDS and hdrHeap are the two that are CONSUMED, and omitting the bias there is a silent no-op: initmem would clear a range starting 0100h below the data, off the front of the image, and never reach the globals at the end. Nothing crashes, and the globals keep whatever the loader left in them. *) PatchWord (hdrCS, pc + LoadBias) ; PatchWord (hdrDS, dataBase + LoadBias) ; PatchWord (hdrHeap, dc + LoadBias) ; PatchWord (hdrMax, 0) END ELSE Err (EUnknown) END END END END ; IF NOT MatchDelim ('.') THEN Err (EPointExp) END ; IF abortFac THEN errNo := errNum ; (* was "errNo := errNo": a self-assignment, because the formal shadowed the module variable, so the error code always reached the caller as 0 *) errPos := txerrPos ; RETURN FALSE END ; errNo := 0 ; errPos := 0 ; RETURN TRUE END Compile ; PROCEDURE CodeBytes () : CARDINAL ; BEGIN RETURN codeSz END CodeBytes ; PROCEDURE DataBytes () : CARDINAL ; BEGIN RETURN dataSz END DataBytes ; PROCEDURE ImageBytes () : CARDINAL ; (* Total linked image size: rtSz (the runtime) + CodeBytes (the program). The program is NOT padded out to the data base here - the linker does that, and only it knows the .COM's final size. *) BEGIN RETURN rtSz + codeSz END ImageBytes ; PROCEDURE DataBase () : CARDINAL ; (* image-absolute offset at which the data area begins (rtSz + 1000H). The linker must place the program's data here and zero-fill from the end of the code up to it. *) BEGIN RETURN dataBase END DataBase ; PROCEDURE ImageByteAt (i : CARDINAL) : BYTE ; (* i-th byte of the WHOLE image, runtime included, so a test can check the real thing a .COM would contain. Returns 0 past the end. *) BEGIN IF i >= rtSz + codeSz THEN RETURN 0 END ; RETURN cbuf [i] END ImageByteAt ; PROCEDURE CodeByteAt (i : CARDINAL) : BYTE ; (* i-th byte of the emitted image, for test harnesses that need to check the generated 8086 code rather than just its size. Returns 0 past the end of the image. *) BEGIN IF i >= codeSz THEN RETURN 0 END ; RETURN cbuf [i] END CodeByteAt ; END Compiler.