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 TextLimit, Length, CharAt, InsertStr, DeleteFromTo ; FROM SYSTEM IMPORT BYTE, ADR ; FROM Posix IMPORT open, read, close ; 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 ; (* Program layout, image offsets. The original puts the runtime and the program's code in CS and the globals in a SEPARATE DS segment, so the .COM contains no data and the code is not limited by a data gap. We have one flat segment (our boot loader), so the same property is obtained by putting the globals at a fixed high image offset: the .COM is code-only, hdrDS points at DataStart, and initmem zeroes it. The code must end below CodeMax, where the boot harness puts the stdin descriptor (memory 7000h). *) DataStart = 8000H ; (* image offset of the first global (memory 8100h) *) CodeMax = 6F00H ; (* code must end below memory 7000h *) MaxSym = 3000 ; MaxPatch = 2000 ; MaxPend = 400 ; MaxFields = 2000 ; (* record fields, in a table of their own: a field is scoped to its record, not global *) MaxArrs = 1000 ; (* array SHAPES, likewise: a symbol points at one, and 2-D indexing needs both ranges *) FileVarSize = 4 ; (* a file variable is our control block: the DOS handle (word) and a mode word (0 closed, 1 read, 2 write). TP3 keeps a buffer here too; we do unbuffered INT 21h I/O. *) (* type codes (TP3 vartp) *) TNone = 0 ; TArray = 1 ; TRecord = 2 ; TSet = 3 ; TPtr = 4 ; TFile = 5 ; TText = 6 ; TUntyp = 7 ; TString = 8 ; TReal = 9 ; TScalar = 10 ; TBool = 11 ; (* CHAR needs a class of its own. It used to be registered as TScalar, which made a CHAR variable indistinguishable from an INTEGER one: the class is all IoCall has to dispatch on, so `write(c)` called wrint (the value 65 became the *address* 65 and it printed whatever lived at 0x41) and `readln(c)` called rdint (which stores a 16-bit result, so it wrote two bytes into a one-byte variable). TP3 TPSRC8 prdtyped/pwriteln dispatches on the type identifier for exactly this reason. BYTE stays TScalar: a BYTE is written as an integer, as in TP3 - but a READ of one is dispatched on the variable's size instead (TPSRC8 prdnum `CMP varsize,#$01 / JA -> rdint, else rdbyte'), so the one thing class alone cannot tell apart is told apart where the size is in hand. *) TChar = 12 ; TEnum = 13 ; (* an enumeration type: ordinal, size 1 (TP3 uses 1 byte below 256 values), bounds in SymEntry.lo/hi *) (* symbol kinds *) KLabel = 100H ; KConst = 200H ; KType = 300H ; KVar = 400H ; KProc = 500H ; KFunc = 600H ; KBuiltin = 700H ; (* standard procedure, see BI_* below *) (* which standard procedure a KBuiltin symbol denotes *) BI_Write = 0 ; BI_WriteLn = 1 ; BI_Read = 2 ; BI_ReadLn = 3 ; BI_Halt = 4 ; BI_Length = 5 ; (* CRT identifiers. There is no unit system, so these are builtins. They are statements (except Length), dispatched in IoCall; each one that is not implemented yet is a loud ENoLib, never a silent no-op. *) BI_ClrScr = 6 ; BI_GotoXY = 7 ; BI_LowVideo = 8 ; BI_NormVideo = 9 ; BI_ClrEol = 10 ; BI_Delay = 11 ; BI_KeyPressed = 12 ; BI_UpCase = 13 ; BI_Succ = 14 ; BI_Pred = 15 ; (* the sub-codes EmCrtSeq takes *) CrtClr = 0 ; CrtDl = 1 ; CrtDh = 2 ; CrtCaret = 3 ; CrtEol = 4 ; CrtLow = 5 ; CrtNorm = 6 ; CrtDelay = 7 ; CrtKey = 8 ; (* keyword tokens *) TkNone = 0 ; TkProgram = 1 ; TkBegin = 2 ; TkEnd = 3 ; TkIf = 4 ; TkThen = 5 ; TkElse = 6 ; TkWhile = 7 ; TkDo = 8 ; TkRepeat = 9 ; TkUntil = 10 ; TkFor = 11 ; TkTo = 12 ; TkDownto = 13 ; TkCase = 14 ; TkOf = 15 ; TkGoto = 16 ; TkExit = 17 ; TkWith = 18 ; TkVar = 19 ; TkConst= 20 ; TkType = 21 ; TkLabel = 22 ; TkProcedure = 23 ; TkFunction = 24 ; TkNil = 25 ; TkAnd = 26 ; TkOr = 27 ; TkNot = 28 ; TkDiv = 29 ; TkMod = 30 ; TkIn = 31 ; TkFile = 32 ; TkText = 33 ; TkRecord = 34 ; TkArray = 35 ; TkSet = 36 ; TkPacked = 37 ; TkForward = 38 ; TkExternal = 39 ; TkAbsolute = 40 ; TkOverlay = 41 ; TkString = 42 ; (* Codes for the SYMBOL operators, as BinOpEmit numbers them. The word operators carry their own Tk* token and need no code here. These are named, not bare numbers, because every precedence level's 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 ; EIoHere = 66 ; (* I/O not allowed here - TPSRC8 prderrtp *) EFileNF = 90 ; (* File not found - TPSRC10 cdincl, errb *) EInclNest = 96 ; (* Illegal nesting of include files - TPSRC10 cdincl *) 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 ; lo, hi : LONGINT ; (* an ORDINAL type's bounds: an enumeration (0..n-1) or a subrange. Needed so `set of T' can size its base. *) fldFirst, fldLast : CARDINAL ; (* a RECORD type's field range in the field table (0,0 when not a record) *) arrIdx : CARDINAL ; (* an ARRAY type's shape in ArrRec (0 = no) *) parmFirst, parmCount : CARDINAL ; (* a PROCEDURE/FUNCTION's parameters: symtab indices, in declaration order *) isKbd : BOOLEAN ; (* the predefined KBD file: reads are console *) isVar : BOOLEAN ; (* a VAR parameter: the slot holds an address *) 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), 4 value on the stack (SaveLeft), 5 string element, address in DI, 7 set value (cls = TSet) *) 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 *) setoff : CARDINAL ; (* SET value: image offset of the bytes *) setbase : CARDINAL ; (* ... the first byte's first element, a multiple of 8 (TP3's hybrid origin) *) setsize : CARDINAL ; (* ... and how many bytes there are *) sz : CARDINAL ; (* width of a kind-1 value: an element or field's size, not its variable's *) END ; DirRec = RECORD rng, chk : BOOLEAN END ; FldRec = RECORD name : ARRAY [0..MaxName] OF CHAR ; cls : CARDINAL ; size : CARDINAL ; elem : CARDINAL ; off : CARDINAL ; (* byte offset within the record *) lo, hi : LONGINT ; (* bounds, for a subrange/enum field *) END ; ArrRec = RECORD n : CARDINAL ; (* number of ranges (1 for array[1..5]) *) lo, hi : ARRAY [0..3] OF LONGINT ; elem : CARDINAL ; (* element size in bytes *) ecls : CARDINAL ; (* element CLASS, for a subscripted value *) END ; (* ---------------------------------------------------------------- *) (* state *) (* ---------------------------------------------------------------- *) VAR srcPos, srcLen : CARDINAL ; (* Include state. srcName is the path the buffer was loaded from, set by SetSource; only its directory is used, because a {$I file} directive names the file relative to the INCLUDING file. Includes are expanded by ExpandIncludes BEFORE parsing, so inclEnd is the end of the include region currently being scanned and inclActive says one is open - a nested {$I} inside that region is error 96, since TP3 permits only one level. incBuf holds one whole include file while it is spliced. *) srcName : ARRAY [0..255] OF CHAR ; inclName : ARRAY [0..127] OF CHAR ; inclPath : ARRAY [0..383] OF CHAR ; inclEnd : CARDINAL ; inclActive : BOOLEAN ; incBuf : ARRAY [0..TextLimit] OF CHAR ; enumLo, enumHi : LONGINT ; (* bounds of the enumeration ParseType just read, handed to DefType which owns the type NAME *) fields : ARRAY [0..MaxFields - 1] OF FldRec ; fldTop : CARDINAL ; (* next free field-table slot *) recFldFirst, recFldLast : CARDINAL ; (* field range ParseType just built *) arrs : ARRAY [0..MaxArrs - 1] OF ArrRec ; arrTop : CARDINAL ; (* next free array-shape slot *) newArrIdx : CARDINAL ; (* ArrRec index+1 for the type just parsed *) constBlob : ARRAY [0..511] OF CHAR ; (* bytes of a set/array typed constant while it is being built *) 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 ; (* the active WITH scopes, innermost last. A DI-based base (an array element addressed at run time) is parked in a two-byte data slot: the body may clobber DI, so each field access reloads it. *) withN : CARDINAL ; withIsDI : ARRAY [0..3] OF BOOLEAN ; withIdx : ARRAY [0..3] OF CARDINAL ; withBoff : ARRAY [0..3] OF CARDINAL ; withSlot : ARRAY [0..3] OF CARDINAL ; withFF : ARRAY [0..3] OF CARDINAL ; withFL : ARRAY [0..3] OF CARDINAL ; lblLo, lblHi : ARRAY [0..31] OF LONGINT ; (* one arm's label list *) lblJmp : ARRAY [0..63] OF CARDINAL ; (* its body jumps: 1 or 2 per label *) 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 the fixed high global area (DataStart = 8000H image, 8100H memory), which is NOT part of the .COM image: initmem zeroes it at startup, as the original's separate DS segment is zeroed. codeSz and dataSz are PROGRAM sizes - the runtime is excluded. *) rtSz, dataBase : CARDINAL ; (* TRUE once Compile has computed rtSz/dataBase, i.e. once the code window has been measured. Ebyte refuses to write past CodeMax/MaxCode and needs to know the window is real before it can: imgReady is FALSE until then, and a zero CodeMax would abort on the very first byte. *) imgReady : BOOLEAN ; (* 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_WrIntW : CARDINAL ; TU_WrChar : CARDINAL ; TU_WrBool : CARDINAL ; TU_WrReal : CARDINAL ; TU_RealWrite : CARDINAL ; TU_WrLn : CARDINAL ; TU_RdInt : CARDINAL ; TU_RdChar : CARDINAL ; TU_RdBool : CARDINAL ; TU_RdLn : CARDINAL ; TU_Halt : CARDINAL ; TU_RdByte : CARDINAL ; (* one-byte variable reads; see IoCall *) TU_WrInl : CARDINAL ; (* inline string literal; NO stack argument *) TU_WrStr : CARDINAL ; (* string variable; address is the stack argument *) TU_RdStr : CARDINAL ; (* readln(s)/read(s); address on the stack, limit in CX *) TU_StrStore : CARDINAL ; (* s := t; dest and source addresses on the stack, limit in CX *) TU_SetOp : CARDINAL ; (* runtime set operations, entries 31..33 *) TU_SetCmp : CARDINAL ; TU_SetCopy : CARDINAL ; TU_CmpStr : CARDINAL ; (* string comparison; two addresses on the stack, signed -1/0/+1 in AX *) TU_StrCat : CARDINAL ; (* string concatenation; dest and source addresses on the stack, limit in CX; exit code 16 if the result would be too long *) 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 ; (* provisional parameter slot, in declaration order; remapped to TP3's BP+4 rule when the list has been read (see ProcFunc) *) dirs : DirRec ; tmpA, tmpB : CARDINAL ; (* global scratch word addresses *) crtAttrOff : CARDINAL ; (* image offset of the text attribute byte that LowVideo/NormVideo set and ClrScr/ClrEol use *) 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 ; (* ---------------------------------------------------------------- *) (* {$I file} include *) (* ---------------------------------------------------------------- *) PROCEDURE SetSource (path : ARRAY OF CHAR) ; (* remember the path the buffer was loaded from; MakeIncludePath keeps only its directory *) VAR i : CARDINAL ; BEGIN i := 0 ; WHILE (i < 255) AND (i <= HIGH (path)) AND (path [i] # 0C) DO srcName [i] := path [i] ; INC (i) END ; srcName [i] := 0C END SetSource ; PROCEDURE ReadWholeFile (path : ARRAY OF CHAR ; VAR n : CARDINAL) : BOOLEAN ; (* Read path into incBuf with the same CR/LF normalisation as LoadWorkFile, and report its length in n. FALSE if it could not be opened. ^Z ends the text, as it does for every other reader here. *) VAR fd : INTEGER ; k : LONGINT ; b : BYTE ; ch : CHAR ; prevCR, emit : BOOLEAN ; BEGIN n := 0 ; fd := open (ADR (path), 0, 0) ; IF fd < 0 THEN RETURN FALSE END ; prevCR := FALSE ; LOOP k := read (fd, ADR (b), 1) ; IF k # 1 THEN EXIT END ; IF b = 26 THEN EXIT END ; (* ^Z *) emit := TRUE ; IF b = 10 THEN IF prevCR THEN emit := FALSE ELSE ch := CHR (13) (* lone LF -> CR *) END ; prevCR := FALSE ELSIF b = 13 THEN ch := CHR (13) ; prevCR := TRUE ELSE ch := CHR (ORD (b)) ; prevCR := FALSE END ; IF emit AND (n <= TextLimit) THEN incBuf [n] := ch ; INC (n) END END ; k := close (fd) ; RETURN TRUE END ReadWholeFile ; PROCEDURE MakeIncludePath () ; (* inclPath := directory (srcName) + inclName, defaulting the extension to .PAS when the name has none (TPSRC10 kpasext). *) VAR i, j, last : CARDINAL ; dot : BOOLEAN ; BEGIN dot := FALSE ; i := 0 ; WHILE (i < 127) AND (inclName [i] # 0C) DO IF inclName [i] = '.' THEN dot := TRUE END ; INC (i) END ; IF (NOT dot) AND (i <= 123) THEN inclName [i] := '.' ; inclName [i + 1] := 'P' ; inclName [i + 2] := 'A' ; inclName [i + 3] := 'S' ; inclName [i + 4] := 0C END ; last := 0 ; i := 0 ; WHILE (i < 256) AND (srcName [i] # 0C) DO IF srcName [i] = '/' THEN last := i + 1 END ; INC (i) END ; j := 0 ; WHILE j < last DO inclPath [j] := srcName [j] ; INC (j) END ; i := 0 ; WHILE (i < 127) AND (inclName [i] # 0C) DO inclPath [j] := inclName [i] ; INC (j) ; INC (i) END ; inclPath [j] := 0C END MakeIncludePath ; PROCEDURE ExpandIncludes () ; (* Replace every {$I name} directive in the buffer with the named file's text, BEFORE parsing. This is a pre-pass, and it has to be. Skip is called by lookahead routines (DeclaresProc, PeekKw, KwAhead) that SAVE AND RESTORE srcPos; an include performed inside Skip would run once during the lookahead and once for real, and the second pass would see the first splice's text and report error 96. A splice also grows the buffer, which a rewind cannot undo. So the whole expansion is done here, in one forward scan with no lookahead, and the parser only ever sees the finished text. The scan has to recognise exactly what the lexer does, or it would expand a directive that the lexer would have read as a string or a comment: a quoted literal is skipped, then star-paren comments (which is why {$I} written inside one is inert - t56_include.inc relies on that), then brace comments, and only then a brace directive. Divergence from the original: TP3 STREAMS the include file line by line and switches back to the outer file at EOF (TPSRC10 fileline/getincl/fileeof); we hold the whole source in TextBuf and address it by index, so the include is spliced in place. A nested {$I} therefore cannot switch back on its own - which TP3 also refuses, and that is the error 96 reported here. *) VAR i, d0, d1, k, ni, n : CARDINAL ; c, letter : CHAR ; isInc : BOOLEAN ; BEGIN i := 0 ; inclActive := FALSE ; inclEnd := 0 ; WHILE (i < Length ()) AND OK () DO c := CharAt (i) ; IF c = "'" THEN INC (i) ; WHILE (i < Length ()) AND (CharAt (i) # "'") DO INC (i) END ; IF i < Length () THEN INC (i) END ELSIF (c = '(') AND (i + 1 < Length ()) AND (CharAt (i + 1) = '*') THEN INC (i, 2) ; WHILE (i < Length ()) AND NOT ((CharAt (i) = '*') AND (i + 1 < Length ()) AND (CharAt (i + 1) = ')')) DO INC (i) END ; IF i < Length () THEN INC (i, 2) END ELSIF (c = '{') AND (i + 1 < Length ()) AND (CharAt (i + 1) = '$') THEN d0 := i ; d1 := i + 2 ; WHILE (d1 < Length ()) AND (CharAt (d1) # '}') DO INC (d1) END ; IF i + 2 < Length () THEN letter := Upper (CharAt (i + 2)) ELSE letter := 0C END ; isInc := FALSE ; IF letter = 'I' THEN k := i + 3 ; WHILE (k < d1) AND ((CharAt (k) = ' ') OR (CharAt (k) = CHR (9))) DO INC (k) END ; IF (k >= d1) OR ((CharAt (k) # '+') AND (CharAt (k) # '-')) THEN isInc := TRUE END END ; IF isInc THEN IF inclActive AND (d0 < inclEnd) THEN srcPos := d0 ; Err (EInclNest) ; (* 96 *) RETURN END ; ni := 0 ; WHILE (k < d1) AND (ni < 127) DO inclName [ni] := CharAt (k) ; INC (k) ; INC (ni) END ; WHILE (ni > 0) AND ((inclName [ni - 1] = ' ') OR (inclName [ni - 1] = CHR (9))) DO DEC (ni) END ; inclName [ni] := 0C ; MakeIncludePath () ; IF NOT ReadWholeFile (inclPath, n) THEN srcPos := d0 ; Err (EFileNF) ; (* 90 *) RETURN END ; DeleteFromTo (d0, d1 - d0 + 1) ; IF NOT InsertStr (d0, incBuf, n) THEN srcPos := d0 ; Err (EMemOvf) ; RETURN END ; inclEnd := d0 + n ; inclActive := TRUE ; i := d0 (* scan the new text too *) ELSE i := d1 + 1 (* ordinary directive: leave it *) END ELSIF c = '{' THEN INC (i) ; WHILE (i < Length ()) AND (CharAt (i) # '}') DO INC (i) END ; IF i < Length () THEN INC (i) END ELSE INC (i) END END ; srcLen := Length () ; srcPos := 0 END ExpandIncludes ; (* ---------------------------------------------------------------- *) (* emission : ebyte / eword / ecall / ejump *) (* ---------------------------------------------------------------- *) PROCEDURE Ebyte (b : BYTE) ; BEGIN IF (pc >= MaxCode) OR (imgReady AND (pc >= CodeMax)) THEN (* The image buffer bound (MaxCode) and the boot harness's code ceiling (CodeMax). Globals no longer sit immediately above the code - they live at DataStart and initmem zeroes them - so this is purely a capacity check: cbuf cannot hold another byte, or the image would reach the stdin descriptor at memory 7000h. Reported as TP3's error 98 (memory overflow) rather than a silent truncation. *) 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 EmMovCxi (imm : CARDINAL) ; BEGIN Ebyte (0B9H) ; Eword (imm) END EmMovCxi ; 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 ; PROCEDURE EmPopSi () ; BEGIN Ebyte (5EH) (* POP SI *) END EmPopSi ; PROCEDURE EmPopAx () ; BEGIN Ebyte (58H) (* POP AX *) END EmPopAx ; (* 91 = XCHG AX,CX, and NOT 93. LoadPair hands the operator the left operand in CX and the right in AX (in the original, and still the commonest, shape: 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 EmOrAxAx () ; (* 09 C0: OR AX,AX - the 8086's flag-only test of AX, and the one the string comparison needs, because cmpstr hands back a signed -1/0/+1 rather than flags. OR AX,AX sets SF and ZF from the value and clears OF and CF, which is exactly the flag state a CMP AX,0 would leave - see EmSetcc and ParseCmp's EmRelSetcc. TEST AX,AX (85 C0) does the same thing, but tests/audit_helpers.py's name grammar has no `Test' mnemonic, and an emitter that cannot be name-checked is worse than one that can. It is NOT EmXorAxAx: XORing AX with itself zeroes it, which would throw away the very value the flags are supposed to describe. *) BEGIN Ebyte (09H) ; Ebyte (0C0H) END EmOrAxAx ; PROCEDURE EmNegAx () ; BEGIN Ebyte (0F7H) ; Ebyte (0D8H) END EmNegAx ; PROCEDURE EmNotAx () ; BEGIN Ebyte (0F7H) ; Ebyte (0D0H) END EmNotAx ; PROCEDURE EmXorAl01 () ; (* XOR AL,#01 - TPSRC9 neglevel's *boolean* NOT: CALL loadatom ; CALL ecode ; B $02,$34,$01 neglevel tests the type first (CMP CL,#$0A -> integer -> NOT AX, CMP CL,#$0B -> boolean -> XOR AL,#01) and reports error 47 for anything else. Emitting NOT AX for a boolean leaves 0FFFEh or 0FFFFh, and the runtime's wrbool tests [BP+4] <> 0, so `not (a = a)' came out TRUE. *) BEGIN Ebyte (34H) ; Ebyte (01H) END EmXorAl01 ; 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 EmRelSetcc (op : CARDINAL) ; (* The relational operator -> SETcc table, in ONE place, because there are now two callers: ParseCmp's numeric arm, whose flags come from EmCmpAxCx, and its string arm, whose flags come from a cmpstr result put through EmOrAxAx. It was factored out of ParseCmp when the string arm arrived, and the note it carried is repeated here rather than referenced, because a comment in the caller about a table in another routine is a comment nobody reads. 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 once, 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. `op' is ParseCmp's own numbering: 1 "=", 2 "<>", 3 "<", 4 ">", 5 ">=", 6 "<=". The condition nibbles are the SIGNED ones (L/G/GE/LE), and both callers hand it a value whose SIGN is the answer - ParseCmp's numeric arm compares with CMP AX,CX on signed data, and cmpstr answers -1/0/+1 - so the signed test is the right one in both places. One table also means that swap cannot come back in one arm and not the other: tests/nonvacuity.sh mutates exactly these two lines, and it now breaks the string comparison at the same time as the numeric one. *) BEGIN 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 END EmRelSetcc ; PROCEDURE EmIncAx () ; BEGIN Ebyte (40H) END EmIncAx ; PROCEDURE EmDecAx () ; BEGIN Ebyte (48H) END EmDecAx ; PROCEDURE EmBpDisp (off, regf : 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 packed top-anchored below BP: locFree is the highest still-free byte (0FFFFh = -1 at entry), a local of size n is based so its LAST byte sits on locFree, and locFree then drops by n. So the first INTEGER local is at off = 0FFFEh = -2, the second at 0FFFCh = -4, and so on - and a string local, which grows UP from its base, lands wholly below BP instead of straddling it. The disp16 form reads those same two bytes as a signed value and addresses the negative slot 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 (* mod=01 rm=110 -> 40H + regf*8 + 6H, mod=10 rm=110 -> 80H + regf*8 + 6H. regf is the ModR/M reg field: 0 when the opcode's register is the accumulator (every original caller), 7 for the DI forms EmLeaDi needs. rm is 110 ([BP+disp]) in both. *) IF off <= 127 THEN Ebyte (VAL (BYTE, 40H + regf * 8 + 6H)) ; Ebyte (VAL (BYTE, off)) ELSE Ebyte (VAL (BYTE, 80H + regf * 8 + 6H)) ; 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, 0) ELSE Ebyte (0A0H) ; Eword ((off + LoadBias) MOD 10000H) END ELSE IF local THEN Ebyte (8BH) ; EmBpDisp (off, 0) 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, 0) ELSE Ebyte (0A2H) ; Eword ((off + LoadBias) MOD 10000H) END ELSE IF local THEN Ebyte (89H) ; EmBpDisp (off, 0) 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, 0) ELSE Ebyte (8DH) ; Ebyte (06H) ; Eword ((off + LoadBias) MOD 10000H) END ; EmPushAx () END EmPushVarAddr ; PROCEDURE EmLeaDi (local : BOOLEAN ; off : CARDINAL) ; (* LEA DI,[BP+disp] / LEA DI,[off] - the run-time address of an indexed string's element, computed once in ParseSub and read by LoadAtom, Assignment and IoCall. It is the same three encodings EmPushVarAddr uses for AX - 8D 7E disp8, 8D BE disp16, 8D 3E off - with the ModR/M reg field set to DI (111) instead of the accumulator, which is why EmBpDisp now takes that field and this is still the one place the disp8/disp16 choice is made. A local is [BP+disp] with no bias; a global is [off] and carries LoadBias, absolute. The later `MOV AL,[DI]` / `MOV [DI],AL` read through DS rather than SS. That is correct here for the same reason TP3's own string ops use DI with the default segment: a .COM loads with DS=SS=CS=ES, and nothing in this compiler or its runtime ever reloads a segment register, so a BP-relative frame address held in DI addresses the same byte. *) BEGIN IF local THEN Ebyte (8DH) ; EmBpDisp (off, 7) ELSE Ebyte (8DH) ; Ebyte (3EH) ; Eword ((off + LoadBias) MOD 10000H) END END EmLeaDi ; PROCEDURE EmAddDiAx () ; BEGIN Ebyte (01H) ; Ebyte (0C7H) END EmAddDiAx ; (* 01 C7: DI := DI + AX *) PROCEDURE EmAddDiImm (n : CARDINAL) ; (* ADD DI,imm16: a record field's offset when the element's address is already in DI (`Sheet[I,J].Field', `with Sheet[I,J] do'). *) BEGIN Ebyte (81H) ; Ebyte (0C7H) ; Eword (n MOD 10000H) END EmAddDiImm ; PROCEDURE EmLdDiGlob (off : CARDINAL) ; (* MOV DI,[off]: recover the base address WITH saved in a scratch word. The body of a WITH may clobber DI, so the address is parked in the data area and reloaded for every field access. *) BEGIN Ebyte (8BH) ; Ebyte (3EH) ; Eword ((off + LoadBias) MOD 10000H) END EmLdDiGlob ; PROCEDURE EmStDiGlob (off : CARDINAL) ; (* MOV [off],DI: the WITH statement's base-address scratch. *) BEGIN Ebyte (89H) ; Ebyte (3EH) ; Eword ((off + LoadBias) MOD 10000H) END EmStDiGlob ; PROCEDURE EmLdAlDi () ; BEGIN Ebyte (8AH) ; Ebyte (05H) END EmLdAlDi ; (* 8A 05: AL := [DI] *) PROCEDURE EmLdAxDi () ; BEGIN Ebyte (8BH) ; Ebyte (05H) END EmLdAxDi ; (* 8B 05: AX := [DI] *) PROCEDURE EmStDiAl () ; BEGIN Ebyte (88H) ; Ebyte (05H) END EmStDiAl ; (* 88 05: [DI] := AL *) PROCEDURE EmPushDi () ; BEGIN Ebyte (57H) END EmPushDi ; (* PUSH DI *) PROCEDURE EmPopDi () ; BEGIN Ebyte (5FH) END EmPopDi ; (* POP DI *) PROCEDURE EmLoadVarInd (off, nbytes : CARDINAL) ; (* AX := the value of a VAR parameter. [BP+off] holds the ADDRESS; BX carries it so the byte/word load has a base register. The address is a DS offset: a .COM has one segment, which is why no segment register appears here. *) BEGIN EmLoadVar (TRUE, off, 2) ; (* AX := [BP+off], the address *) Ebyte (89H) ; Ebyte (0C3H) ; (* MOV BX,AX *) IF nbytes = 1 THEN Ebyte (8AH) ; Ebyte (07H) ; (* MOV AL,[BX] *) EmMovAh0 () ELSE Ebyte (8BH) ; Ebyte (07H) (* MOV AX,[BX] *) END END EmLoadVarInd ; PROCEDURE EmStoreVarIndPrep (off : CARDINAL) ; (* DI := the address of a VAR parameter, then PUSH DI. The push protects it across the parse of the right-hand side, which may use DI for a string element of its own. EmStoreInd finishes the store after POP DI. *) BEGIN Ebyte (8BH) ; EmBpDisp (off, 7) ; (* MOV DI,[BP+off] *) EmPushDi () END EmStoreVarIndPrep ; PROCEDURE EmStDiImm (off, v : CARDINAL) ; (* MOV byte [DI+off],imm8: one byte of a set constructor stored through a DI-addressed record field. Sets are at most 32 bytes, so disp8 is enough. *) BEGIN Ebyte (0C6H) ; Ebyte (45H) ; Ebyte (VAL (BYTE, off)) ; Ebyte (VAL (BYTE, v)) END EmStDiImm ; PROCEDURE EmStDiAlOff (off : CARDINAL) ; (* MOV [DI+off],AL: one byte of a real copied through a DI-addressed field. *) BEGIN Ebyte (88H) ; Ebyte (45H) ; Ebyte (VAL (BYTE, off)) END EmStDiAlOff ; PROCEDURE EmLdAlDiOff (off : CARDINAL) ; (* MOV AL,[DI+off]: the byte of a set variable that holds an element's bit. *) BEGIN Ebyte (8AH) ; Ebyte (45H) ; Ebyte (VAL (BYTE, off)) END EmLdAlDiOff ; PROCEDURE EmCmpAlImm (v : CARDINAL) ; BEGIN Ebyte (3CH) ; Ebyte (VAL (BYTE, v)) END EmCmpAlImm ; (* CMP AL,imm8 *) PROCEDURE EmSubAlImm (v : CARDINAL) ; BEGIN Ebyte (2CH) ; Ebyte (VAL (BYTE, v)) END EmSubAlImm ; (* SUB AL,imm8 *) PROCEDURE EmMovClAl () ; BEGIN Ebyte (88H) ; Ebyte (0C1H) END EmMovClAl ; (* MOV CL,AL *) PROCEDURE EmAndClImm (v : CARDINAL) ; BEGIN Ebyte (80H) ; Ebyte (0E1H) ; Ebyte (VAL (BYTE, v)) END EmAndClImm ; PROCEDURE EmShrAx1 () ; BEGIN Ebyte (0D1H) ; Ebyte (0E8H) END EmShrAx1 ; (* SHR AX,1 *) PROCEDURE EmMovBxi (v : CARDINAL) ; BEGIN Ebyte (0BBH) ; Eword (v MOD 10000H) END EmMovBxi ; (* MOV BX,imm16 *) PROCEDURE EmLeaBx (off : CARDINAL) ; (* LEA BX,[BP+off]: the address of a local set. *) BEGIN Ebyte (8DH) ; EmBpDisp (off, 3) END EmLeaBx ; PROCEDURE EmMovBxDi () ; BEGIN Ebyte (89H) ; Ebyte (0FBH) END EmMovBxDi ; (* MOV BX,DI *) PROCEDURE EmAddBxAx () ; BEGIN Ebyte (01H) ; Ebyte (0C3H) END EmAddBxAx ; (* ADD BX,AX *) PROCEDURE EmLdAlBx () ; BEGIN Ebyte (8AH) ; Ebyte (07H) END EmLdAlBx ; (* MOV AL,[BX] *) PROCEDURE EmMovDlImm (v : CARDINAL) ; BEGIN Ebyte (0B2H) ; Ebyte (VAL (BYTE, v)) END EmMovDlImm ; PROCEDURE EmShlDlCl () ; BEGIN Ebyte (0D2H) ; Ebyte (0E2H) END EmShlDlCl ; (* SHL DL,CL *) PROCEDURE EmAndAlDl () ; BEGIN Ebyte (20H) ; Ebyte (0D0H) END EmAndAlDl ; (* AND AL,DL *) PROCEDURE EmAndAlImm (v : CARDINAL) ; BEGIN Ebyte (24H) ; Ebyte (VAL (BYTE, v)) END EmAndAlImm ; (* AND AL,imm8 *) PROCEDURE EmStoreInd (nbytes : CARDINAL) ; (* [DI] := AL/WORD, after POP DI - the companion of EmStoreVarIndPrep. *) BEGIN IF nbytes = 1 THEN EmStDiAl () (* MOV [DI],AL *) ELSE Ebyte (89H) ; Ebyte (05H) (* MOV [DI],AX *) END END EmStoreInd ; 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.lo := 0 ; e.hi := 0 ; e.fldFirst := 0 ; e.fldLast := 0 ; e.arrIdx := 0 ; e.parmFirst := 0 ; e.parmCount := 0 ; e.isKbd := FALSE ; e.isVar := FALSE ; 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) ; (* A name may be declared twice only in the SAME scope. This used to reject any name Search could see, so a parameter could not shadow a global - legal ISO Pascal, and CALC.INC's `procedure IBMCh(var Ch: Char)' does exactly that (`Ch' is a global). Same-level duplicates stay errors: two parameters in one list, two locals, or two globals. *) VAR i : CARDINAL ; BEGIN IF Search (nm, i) THEN IF symtab [i].level = lexnest THEN Err (EUnknown) END 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. Include directives are already gone by the time Skip runs: ExpandIncludes splices them into the buffer first, so the {$I file} spelling never reaches here. {$I+}/{$I-} still do, and stay the I/O-check toggle, exactly as TPSRC10 cdirec splits them on the sign. *) VAR ch : CHAR ; letter : CHAR ; BEGIN WHILE NOT abortFac DO WHILE IsBlank (CurCh ()) DO ch := GetCh () END ; IF CurCh () = '{' THEN ch := GetCh () ; IF CurCh () = '$' THEN ch := GetCh () ; letter := Upper (GetCh ()) ; IF CurCh () = '+' THEN ch := GetCh () ; IF letter = 'I' THEN dirs.chk := TRUE END ; IF letter = 'R' THEN dirs.rng := TRUE END ELSIF CurCh () = '-' THEN ch := GetCh () ; IF letter = 'I' THEN dirs.chk := FALSE END ; IF letter = 'R' THEN dirs.rng := FALSE END END END ; WHILE (CurCh () # '}') AND (CurCh () # 0C) DO ch := GetCh () END ; IF CurCh () = '}' THEN ch := GetCh () END ELSIF (CurCh () = '(') AND (PeekAhead (1) = '*') THEN ch := GetCh () ; ch := GetCh () ; IF CurCh () = '$' THEN ch := GetCh () ; letter := Upper (GetCh ()) ; IF CurCh () = '+' THEN ch := GetCh () ; IF letter = 'I' THEN dirs.chk := TRUE END ; IF letter = 'R' THEN dirs.rng := TRUE END ELSIF CurCh () = '-' THEN ch := GetCh () ; IF letter = 'I' THEN dirs.chk := FALSE END ; IF letter = 'R' THEN dirs.rng := FALSE END END END ; LOOP IF (CurCh () = '*') AND (PeekAhead (1) = ')') THEN ch := GetCh () ; ch := GetCh () ; EXIT END ; IF CurCh () = 0C THEN EXIT END ; ch := GetCh () END ELSE RETURN END END END Skip ; PROCEDURE GetWord () ; (* read identifier into wrd (uppercased); next char must be alpha *) VAR i : CARDINAL ; ch : CHAR ; BEGIN i := 0 ; ch := GetCh () ; LOOP IF i > MaxName THEN wrd [MaxName] := 0C ; RETURN END ; wrd [i] := Upper (ch) ; INC (i) ; ch := CurCh () ; IF NOT AlphaNum (ch) THEN wrd [i] := 0C ; RETURN END ; ch := GetCh () END END GetWord ; PROCEDURE WddTok () : CARDINAL ; (* map wrd -> keyword token *) VAR i : CARDINAL ; BEGIN i := 1 ; WHILE i <= 42 DO IF kName [i] [0] # 0C THEN IF NameEq (wrd, kName [i]) THEN RETURN kTk [i] END END ; INC (i) END ; RETURN TkNone END WddTok ; PROCEDURE DeclaresProc () : BOOLEAN ; (* Does the REST of the source declare a PROCEDURE or a FUNCTION? Needed because the declaration part is compiled BEFORE the main statement part, so a procedure's code lands between the program prologue and the main body - and nothing jumps over it. A program with a procedure therefore ran off the end of the prologue, straight into the first procedure, which read its argument out of an uninitialised frame and returned to address 0. Every Pascal program containing a procedure was broken; `t13_proc` compiled and was never executed, so nothing saw it. The jump that fixes it has to be emitted BEFORE the declaration part, but whether one is needed is only known AFTER - so the only honest options are to emit it unconditionally (3 dead bytes in every program, and every code size in expected.tsv moves) or to know the answer in advance. This is the second: it scans ahead and puts srcPos back. That is safe because the whole program is already in `src` and `srcPos` is a plain index into it - the same trick PeekKw and KwAhead use. The scan looks for the keywords anywhere in the remainder rather than tracking the nesting of `begin`s, which is deliberately loose: a program with no procedures that merely mentions the word in a string literal would get a 3-byte jump to the next instruction, which is harmless, whereas tracking the main `begin` against a procedure's `begin` would be a second parser to get wrong. *) VAR save : CARDINAL ; found : BOOLEAN ; tk : CARDINAL ; ch : CHAR ; BEGIN save := srcPos ; found := FALSE ; tk := TkNone ; (* so the answer is defined if src is empty *) (* Step over delimiters as well as blanks. Stopping at the first non-letter looked reasonable and was wrong: `var x : integer ;` is full of ':' and ';', so the scan gave up inside the variable section and never reached the PROCEDURE. The loop ends at the end of the source, not at the first punctuation. *) WHILE (NOT found) AND (srcPos < srcLen) DO Skip () ; IF Alpha (CurCh ()) THEN GetWord () ; tk := WddTok () ; IF (tk = TkProcedure) OR (tk = TkFunction) THEN found := TRUE END ELSE ch := GetCh () (* a ':' or ';' - step over it *) END END ; srcPos := save ; RETURN (tk = TkProcedure) OR (tk = TkFunction) END DeclaresProc ; PROCEDURE KwAhead (word : ARRAY OF CHAR) : BOOLEAN ; (* does the next token (past blanks/comments) equal the keyword 'word', without consuming it? srcPos is saved and restored. *) VAR save : CARDINAL ; k : BOOLEAN ; BEGIN save := srcPos ; Skip () ; k := FALSE ; IF Alpha (CurCh ()) THEN GetWord () ; k := NameEq (wrd, word) END ; srcPos := save ; RETURN k END KwAhead ; PROCEDURE PeekKw (VAR tok : CARDINAL) ; (* peek at the next keyword token without consuming it *) VAR i : CARDINAL ; BEGIN tok := TkNone ; i := 1 ; WHILE i <= 42 DO IF kName [i] [0] # 0C THEN IF KwAhead (kName [i]) THEN tok := kTk [i] ; RETURN END END ; INC (i) END END PeekKw ; PROCEDURE MatchKey (VAR tok : CARDINAL) : BOOLEAN ; (* skip; if next symbol is a word, read it into wrd and set its token. Returns TRUE when a word was read (tok = TkNone for plain ids). *) BEGIN tok := TkNone ; Skip () ; IF NOT Alpha (CurCh ()) THEN RETURN FALSE END ; GetWord () ; tok := WddTok () ; RETURN TRUE END MatchKey ; PROCEDURE MatchDelim (ch : CHAR) : BOOLEAN ; BEGIN Skip () ; IF CurCh () = ch THEN DropCh (GetCh ()) ; RETURN TRUE END ; RETURN FALSE END MatchDelim ; PROCEDURE MatchAssign () : BOOLEAN ; BEGIN Skip () ; IF (CurCh () = ':') AND (PeekAhead (1) = '=') THEN DropCh (GetCh ()) ; DropCh (GetCh ()) ; RETURN TRUE END ; RETURN FALSE END MatchAssign ; PROCEDURE MatchRange () : BOOLEAN ; BEGIN Skip () ; IF (CurCh () = '.') AND (PeekAhead (1) = '.') THEN DropCh (GetCh ()) ; DropCh (GetCh ()) ; RETURN TRUE END ; RETURN FALSE END MatchRange ; PROCEDURE ExpectDelim (ch : CHAR ; n : CARDINAL) ; BEGIN Skip () ; IF CurCh () = ch THEN DropCh (GetCh ()) ELSE Err (n) END END ExpectDelim ; PROCEDURE HexVal (ch : CHAR) : CARDINAL ; BEGIN IF (ch >= '0') AND (ch <= '9') THEN RETURN ORD (ch) - ORD ('0') ELSIF (ch >= 'A') AND (ch <= 'F') THEN RETURN ORD (ch) - ORD ('A') + 10 END ; RETURN ORD (ch) - ORD ('a') + 10 END HexVal ; PROCEDURE RdIntConst (VAR v : LONGINT) ; (* bare integer constant; current char is digit or '$' *) VAR acc : LONGINT ; BEGIN acc := 0 ; IF CurCh () = '$' THEN DropCh (GetCh ()) ; WHILE IsHexCh (CurCh ()) DO acc := acc * 16 + VAL (LONGINT, HexVal (CurCh ())) ; DropCh (GetCh ()) END ELSE WHILE Digit (CurCh ()) DO acc := acc * 10 + VAL (LONGINT, ORD (CurCh ()) - ORD ('0')) ; DropCh (GetCh ()) END END ; v := acc END RdIntConst ; PROCEDURE StrNew (first : CARDINAL ; hasFirst : BOOLEAN ) : CARDINAL ; (* Open a pool slot for a string literal, optionally pre-seeded with its first character. RdConst has to read the first character before it can tell a one-character literal from a longer one - the "is the next character another quote?" test only makes sense once something has been read - so the seeding has to happen here and has to advance strTop. Leaving strTop alone and letting the caller write the character by hand is a trap: strTop is the next FREE byte, so the first StrPut lands on top of the seeded character and overwrites it. (That bug shipped the literal 'hi' as 69 00 - 'i' then NUL.) *) VAR x : CARDINAL ; BEGIN IF strCnt > HIGH (strOff) THEN Err (ECompOvf) ; (* too many literals in one unit *) RETURN 0 END ; x := strCnt ; strOff [x] := strTop ; strLen [x] := 0 ; INC (strCnt) ; IF hasFirst THEN strPool [strTop] := CHR (first) ; INC (strTop) ; strLen [x] := 1 END ; rdStrX := x ; RETURN x END StrNew ; PROCEDURE StrPut (x : CARDINAL ) ; (* append the current source character to pool slot x *) BEGIN IF x > HIGH (strOff) THEN RETURN END ; IF strTop > HIGH (strPool) THEN Err (ECompOvf) ; (* literal longer than the pool *) RETURN END ; strPool [strTop] := CurCh () ; INC (strTop) ; INC (strLen [x]) END StrPut ; PROCEDURE RdConst (VAR v : LONGINT ; VAR cls : CARDINAL ; VAR isStr : BOOLEAN) ; (* scalar or string constant. A string literal's text is collected into the pool and its slot index left in rdStrX; a single-character literal stays a TScalar holding its character code, which is what "c := 'a'" wants. *) CONST q = AposC ; VAR ch : CHAR ; idx : CARDINAL ; BEGIN isStr := FALSE ; cls := TScalar ; v := 0 ; Skip () ; IF CurCh () = '$' THEN RdIntConst (v) ; cls := TScalar ELSIF Digit (CurCh ()) THEN RdIntConst (v) ; IF (CurCh () = '.') AND (Digit (PeekAhead (1))) THEN cls := TReal ; DropCh (GetCh ()) END ; IF (CurCh () = 'E') OR (CurCh () = 'e') THEN cls := TReal ; DropCh (GetCh ()) END ; IF cls = TReal THEN WHILE AlphaNum (CurCh ()) OR (CurCh () = '.') OR (CurCh () = '-') OR (CurCh () = '+') DO DropCh (GetCh ()) END END ELSIF CurCh () = '^' THEN (* TP3 caret character constant, unquoted: ^M is CR (13), ^[ is ESC (27), ^@ is 0. The value is the upper-cased character minus 64, so the +256-MOD-256 keeps ^@ and any control character from wrapping. *) DropCh (GetCh ()) ; IF CurCh () = 0C THEN Err (EUnknown) ELSE ch := Upper (GetCh ()) ; v := VAL (LONGINT, (ORD (ch) + 256 - 64) MOD 256) ; cls := TScalar END ELSIF CurCh () = '#' THEN (* TP3 decimal character constant: #27, #255. *) DropCh (GetCh ()) ; IF Digit (CurCh ()) THEN RdIntConst (v) ; cls := TScalar ELSE Err (EUnknown) END ELSIF Alpha (CurCh ()) THEN (* TRUE / FALSE, or a NAMED constant - an enumerator (`[Constant, Formula]'), or any earlier const. A constant expression may name a constant, and set literals and `case' labels are full of enumerators. *) GetWord () ; IF NameEq (wrd, "TRUE") THEN v := 1 ; cls := TBool ELSIF NameEq (wrd, "FALSE") THEN v := 0 ; cls := TBool ELSIF Search (wrd, idx) AND (symtab [idx].tag = KConst) THEN v := symtab [idx].lval ; cls := symtab [idx].cls ELSE Err (EUnknown) END ELSIF ORD (CurCh ()) = q THEN DropCh (GetCh ()) ; IF ORD (CurCh ()) = q THEN (* '' - the empty string. It used to be reported as the scalar 39, so writeln('') printed a single quote mark. It is a string of length zero, and an inline zero-length literal is exactly what the runtime's JCXZ path is for. *) DropCh (GetCh ()) ; isStr := TRUE ; cls := TString ; v := 0 ; rdStrX := StrNew (0, FALSE) ELSIF (CurCh () = 0C) OR ((ORD (CurCh ()) = 0DH)) OR ((ORD (CurCh ()) = 0AH)) THEN Err (EUnknown) ELSE v := VAL (LONGINT, ORD (GetCh ())) ; cls := TScalar ; IF ORD (CurCh ()) = q THEN DropCh (GetCh ()) ELSE isStr := TRUE ; cls := TString ; (* Scan to the closing quote. NB: the loop condition must test the CURRENT character and only the current character. The obvious-looking "while CurCh # quote" with a "if PeekAhead(1) = quote then consume two" body is wrong: consuming the quote moves the cursor past it, so the next condition test sees the character AFTER the literal, is satisfied, and the scan runs on to end-of-buffer - which silently eats the rest of the program and makes every later error point at end-of-file. Stop on the quote itself, and treat a doubled quote as one embedded quote character. The first character is already gone - it was read into v above - so the pool slot is pre-seeded with it. *) rdStrX := StrNew (VAL (CARDINAL, v), TRUE) ; LOOP IF ORD (CurCh ()) = q THEN IF ORD (PeekAhead (1)) = q THEN StrPut (rdStrX) ; (* '' inside *) DropCh (GetCh ()) ; DropCh (GetCh ()) ELSE EXIT (* closing quote *) END ELSIF (CurCh () = 0C) OR (ORD (CurCh ()) = 0DH) THEN Err (EUnknown) ; (* unterminated *) EXIT ELSE StrPut (rdStrX) ; DropCh (GetCh ()) END END ; IF ORD (CurCh ()) = q THEN DropCh (GetCh ()) END END END ELSE Err (EUnknown) END END RdConst ; (* ---------------------------------------------------------------- *) (* forward declarations *) (* ---------------------------------------------------------------- *) 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, cleanup : CARDINAL) ; FORWARD ; PROCEDURE SlotSize (cls, size : CARDINAL) : CARDINAL ; FORWARD ; PROCEDURE ParamSlotBytes (e : SymEntry) : CARDINAL ; FORWARD ; (* ---------------------------------------------------------------- *) (* expressions (TPSRC9) *) (* ---------------------------------------------------------------- *) PROCEDURE VarSize (r : ERes) : CARDINAL ; (* The width of a kind-1 value. An element (`b[i]') or a field (`r.f') has a size of its own, which is NOT its variable's; when the parser has recorded one, it wins. Otherwise the variable's declared size is the answer. *) BEGIN IF r.sz > 0 THEN RETURN r.sz END ; RETURN symtab [r.idx].size END VarSize ; 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. *) VAR emsz : CARDINAL ; BEGIN IF r.cls = TString THEN Err (ENoLib) ; (* string value used as a number *) r.kind := 2 ; RETURN END ; IF r.cls = TSet THEN (* A set is bytes, not a 16-bit value. It is legal as the right operand of `in' (and later as a whole-value operand of `+'/`*'/'='/assignment), all of which handle it BEFORE LoadAtom - but never as a number, which would otherwise load its first two bytes as if it were an integer. *) Err (ENoLib) ; r.kind := 2 ; RETURN END ; IF r.kind = 5 THEN (* An element whose address ParseSub computed into DI (LEA DI,[base] / ADD DI,AX): a string character, or an array element of one or two bytes. Zeroing AH keeps a one-byte value a clean 16-bit char. The read must happen HERE, before anything else is emitted: the caller reaches this immediately after parsing the subscript, or - for a binary operator - SaveLeft has already materialised it, so DI is still the element's address. *) IF VarSize (r) > 2 THEN Err (ENoLib) ; (* a whole record/array as a value *) r.kind := 2 ; RETURN END ; IF VarSize (r) = 2 THEN EmLdAxDi () ELSE EmLdAlDi () ; EmMovAh0 () END ; 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].isVar THEN (* A VAR parameter: [BP+off] holds the address, and the value is one level down. r.boff is necessarily 0 - a by-reference parameter is a scalar in this increment, so it has nothing to subscript. *) IF r.boff # 0 THEN Err (ENoLib) ; r.kind := 2 ; RETURN END ; EmLoadVarInd (symtab [r.idx].off, VarSize (r)) ; r.kind := 2 ; RETURN END ; IF (VarSize (r) > 2) AND NOT ((r.cls = TChar) AND (symtab [r.idx].cls = TString)) THEN Err (ENoLib) ELSE (* s[i] indexes one byte of a string, not the string, so its width is one whatever the variable's declared width is. *) emsz := VarSize (r) ; IF (r.cls = TChar) AND (symtab [r.idx].cls = TString) THEN emsz := 1 END ; EmLoadVar (symtab [r.idx].local, (symtab [r.idx].off + r.boff) MOD 10000H, emsz) ; IF emsz = 1 THEN EmMovAh0 () END ; r.kind := 2 END END END LoadAtom ; PROCEDURE ParseSub (VAR r : ERes) ; (* consume '[' expr ']' while present. A CONSTANT index folds into the base offset boff, exactly as before. A VARIABLE index on a STRING cannot fold - off+i is a run-time value - so it is computed once here into DI and r.kind drops to 5, which is how LoadAtom, Assignment and IoCall are told the element's address is in DI. Arrays still accept only a constant index: a variable array subscript needs the element-size scaling that a one-byte string element does not, and it is item 2. *) VAR t : ERes ; ai, fi, nd, k, st : CARDINAL ; coff : LONGINT ; accOnStack, haveVar, more : BOOLEAN ; found : BOOLEAN ; BEGIN LOOP Skip () ; IF CurCh () = '.' THEN (* FIELD selection: `r.f'. The field's offset adds to the record base's, and the value's class and WIDTH become the field's - which is the whole reason a width rides on the expression (VarSize). *) DropCh (GetCh ()) ; Skip () ; IF NOT Alpha (CurCh ()) THEN Err (EUnknown) ; RETURN END ; GetWord () ; IF symtab [r.idx].fldFirst >= symtab [r.idx].fldLast THEN Err (ESimpType) ; (* not a record *) RETURN END ; fi := symtab [r.idx].fldFirst ; found := FALSE ; WHILE (fi < symtab [r.idx].fldLast) AND NOT found DO IF NameEq (fields [fi].name, wrd) THEN found := TRUE ELSE INC (fi) END END ; IF NOT found THEN Err (EUnknown) ; RETURN END ; IF r.kind = 5 THEN (* The element's address is in DI: a field is a fixed offset from it. The array symbol already carries the element record's field range (DefVar copies recFldFirst/recFldLast), which is why the lookup above works for `Sheet[I,J].Field' too. *) IF fields [fi].off # 0 THEN EmAddDiImm (fields [fi].off) END ELSE r.boff := W16 (VAL (LONGINT, r.boff) + VAL (LONGINT, fields [fi].off)) ; END ; r.cls := fields [fi].cls ; r.sz := fields [fi].size ; IF r.cls = TSet THEN (* ParseVar set setoff only when the SYMBOL itself was a set; for an array/record the class was still TArray/TRecord then, so the base offset has to be recorded now. *) r.setoff := symtab [r.idx].off ; r.setbase := fields [fi].elem ; r.setsize := fields [fi].size END ELSIF CurCh () = '[' THEN DropCh (GetCh ()) ; IF symtab [r.idx].cls = TString THEN (* s[i]: a STRING is a length byte at s[0] followed by the characters, so index i selects the one byte at off+i. A second subscript on a character is not a type. *) ParseExpr (t) ; IF OK () THEN IF r.cls = TChar THEN Err (ESimpType) ; RETURN END ; IF t.kind = 0 THEN (* constant index: fold it into boff, as an array's does, and r.cls drops to TChar so every consumer below - LoadAtom, Assignment, IoCall - sees a one-byte value instead of the whole string. *) r.boff := W16 (VAL (LONGINT, r.boff) + t.imm) ELSE (* Variable index. Compute the element address once, now: the index is evaluated into AX (LoadAtom is a no-op for a kind-2 value and re-reads [DI] for a nested subscript), then DI := base + AX. This is TP3's indstr/ialoop shape (TPSRC9 1100-1111, 1200-1229), which likewise holds the address in DI until the byte is loaded or stored; a register is what lets a later LoadAtom read [DI] and a later assignment PUSH DI across its right-hand side. *) LoadAtom (t) ; EmLeaDi (symtab [r.idx].local, (symtab [r.idx].off + r.boff) MOD 10000H) ; EmAddDiAx () ; r.kind := 5 END ; r.cls := TChar ; r.sz := 1 END ; ExpectDelim (']', ENoSemi) ELSIF symtab [r.idx].cls = TArray THEN (* An array subscript LIST: one expression per dimension, comma separated. The byte offset is sum over k of (i[k] - lo[k]) * stride[k] where stride[k] is the element size times the count of every LATER dimension (row-major: the LAST dimension varies fastest). A constant index folds into coff; a run-time one is scaled as soon as it is parsed and summed on the STACK, because parsing the next index may clobber AX and DI. *) IF (r.kind = 5) OR (symtab [r.idx].arrIdx = 0) THEN Err (ESimpType) ; RETURN END ; ai := symtab [r.idx].arrIdx - 1 ; nd := 0 ; coff := 0 ; accOnStack := FALSE ; haveVar := FALSE ; LOOP IF nd >= arrs [ai].n THEN Err (ETypeErr) ; RETURN END ; ParseExpr (t) ; IF NOT OK () THEN RETURN END ; st := arrs [ai].elem ; k := nd + 1 ; WHILE k < arrs [ai].n DO st := st * W16 (arrs [ai].hi [k] - arrs [ai].lo [k] + 1) ; INC (k) END ; Skip () ; more := CurCh () = ',' ; IF t.kind = 0 THEN coff := coff + (t.imm - arrs [ai].lo [nd]) * VAL (LONGINT, st) ELSE LoadAtom (t) ; IF arrs [ai].lo [nd] # 0 THEN EmMovCxi (W16 (arrs [ai].lo [nd])) ; EmSubAxCx () END ; IF st # 1 THEN EmMovCxi (st) ; EmMulAxCx () END ; IF more THEN (* the next dimension's expression will clobber AX: park the running sum. A SINGLE index skips this entirely, so 1-D code is byte-identical to the old path. *) IF accOnStack THEN EmPopCx () ; EmAddAxCx () ; EmPushAx () ELSE EmPushAx () ; accOnStack := TRUE END ELSE (* last dimension: AX is the total *) IF accOnStack THEN EmPopCx () ; EmAddAxCx () ; accOnStack := FALSE END ; haveVar := TRUE END END ; INC (nd) ; IF more THEN DropCh (GetCh ()) ELSE EXIT END END ; IF nd # arrs [ai].n THEN (* fewer subscripts than dimensions: the value would be a sub-array, which has no scalar representation *) Err (ETypeErr) ; RETURN END ; ExpectDelim (']', ENoSemi) ; IF accOnStack THEN (* the last dimensions were constant: the parked sum is still on the stack, and AX is the total *) EmPopAx () ; accOnStack := FALSE END ; IF haveVar THEN EmLeaDi (symtab [r.idx].local, (symtab [r.idx].off + r.boff + W16 (coff)) MOD 10000H) ; EmAddDiAx () ; r.kind := 5 ELSE r.boff := W16 (VAL (LONGINT, r.boff) + coff) END ; r.sz := arrs [ai].elem ; r.cls := arrs [ai].ecls ELSE ParseExpr (t) ; IF OK () THEN IF t.kind # 0 THEN Err (ENoLib) ELSE Err (ESimpType) END END ; ExpectDelim (']', ENoSemi) END ELSE RETURN END 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 ; IF r.cls = TSet THEN (* a set value: carry where its bytes are so ParseCmp can fold `in' and (later) compare. A set VARIABLE is still refused at its declaration, so today this is a typed constant or an inline literal. *) r.setoff := symtab [r.idx].off ; r.setbase := symtab [r.idx].elem ; r.setsize := symtab [r.idx].size END ; r.sz := symtab [r.idx].size ; 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 StrConcat (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ; FORWARD ; PROCEDURE StrOperand (r : ERes) : BOOLEAN ; FORWARD ; 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 StrOperand (left) OR StrOperand (right) THEN (* A string OPERAND - a STRING or a CHAR, which is a one-character string for this purpose - makes this a string operation, and `+' is the only one ISO Modula-2 defines: every other binary operator reached here (OR, and the multiplicative and additive numeric ops) has no meaning over a STRING, and StrConcat rejects it. The test is StrOperand and NOT `cls = TString' because of the two CHAR operands. `'a' + 'b'' has no STRING in it at all, so a TString-only test let it fall through to the integer path, where the character codes were added and CHR(195) was printed - a silently wrong program rather than an error (see t53_strcat_type). A CHAR operand is still a string operand, which is also what makes `a + ch' concatenate. Handling it here, at the head of the one routine every binary operator funnels through, is what keeps `a + b', `writeln(a + b)', `(a + b) = c' and `s := a + b + c' all going through the same emission. *) StrConcat (op, left, right, res) ; RETURN END ; 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 ; LoadPair (left, right) ; 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 ; LoadPair (left, right) ; 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 ; LoadPair (left, right) ; 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 ; (* ---------------------------------------------------------------- *) (* keeping an operand alive across the parse of the other one *) (* ---------------------------------------------------------------- *) PROCEDURE SaveLeft (VAR left : ERes) ; (* Called the moment the operator has been recognised, i.e. *before* the right-hand operand is parsed. Every binary level in this parser has the shape left := r ; ParseXxx (right) ; BinOpEmit (op, left, right, r) ; so the right-hand operand's code is emitted between those two lines, and the left-hand operand has to survive that. For kind 0 (a constant) and kind 1 (a named variable) there is nothing to survive: LoadAtom re-emits the MOV or the load at the operator site, and no code has been emitted for the left yet. A kind-2 value is different - its code is already in the image and its value exists only in AX, which the right-hand parse is about to overwrite. The value had to be parked on the stack instead. TPSRC9 does exactly this in the other order: addptr and mulptr CALL pushres (which calls loadatom and sets flgpshax) *before* CALL mullevel, so PUSH AX lands in the image ahead of the right-hand operand's code. Without this, `(p > q) or (q > p)` emitted both comparisons and then ORed the *second* comparison's result with itself - which is why it printed FALSE for TRUE or FALSE. *) BEGIN IF left.kind = 2 THEN EmPushAx () ; left.kind := 4 (* 4 = on the top of the stack *) ELSIF left.kind = 5 THEN (* A string element whose address is in DI. This is the one place the address must be spent BEFORE the right-hand operand is parsed: DI cannot survive it, because the right operand may hold a subscript of its own (which reuses DI) or call a routine (which may clobber it). Reading [DI] now - which LoadAtom does, turning kind 5 into kind 2 - and pushing the value is exactly what the kind-2 case above does next, so the two branches converge on kind 4. A subscript on the RIGHT is fine: it sets DI after this point and LoadPair reads it immediately, with no parse in between. *) LoadAtom (left) ; (* AL := [DI], AH := 0; kind := 2 *) EmPushAx () ; left.kind := 4 END END SaveLeft ; PROCEDURE LoadPair (VAR left, right : ERes) ; (* Materialise both operands of a binary operator so that, once this returns, AX holds the LEFT one and CX the RIGHT one - which is the state EmAddAxCx/EmSubAxCx/EmMulAxCx/EmIDivAxCx/EmAndAxCx/EmOrAxCx/EmCmpAxCx all expect (see EmXchgAxCx). Three shapes, and only three: left.kind = 4 SaveLeft pushed it before the right operand was parsed, so the right value is in AX and the left one is on the stack: load the right (a no-op for kind 2), pop the left into CX, then swap. right.kind = 2 The right value is in AX, and loading the left would destroy it: push the right, load the left, then pop the right straight into CX. No swap needed. neither Both can still be materialised from scratch, and neither is at risk, so this is the original sequence. A kind-5 right-hand operand takes that last shape, and is safe there: the only instruction emitted before its LoadAtom is the left's, and MOV AX,[var] and MOV AX,imm do not touch DI, so [DI] still holds the element address. Whichever shape is taken, exactly one push is matched by exactly one pop. *) BEGIN IF left.kind = 4 THEN LoadAtom (right) ; EmPopCx () ; EmXchgAxCx () ELSIF right.kind = 2 THEN EmPushAx () ; LoadAtom (left) ; EmPopCx () ELSE LoadAtom (left) ; EmPushAx () ; LoadAtom (right) ; EmPopCx () ; EmXchgAxCx () END END LoadPair ; PROCEDURE EmStrBlob (r : ERes) : CARDINAL ; (* Emit a string literal's in the code stream behind a JMP and return the image offset of the LENGTH byte. Shared by EmPushStrAddr (which pushes that address) and EmPushStrSlot (which copies the bytes onto the stack for a string value parameter). *) VAR n, len, here : CARDINAL ; BEGIN len := strLen [r.strx] ; IF len > 255 THEN (* As in IoCall: the length is one byte, so a longer literal would wrap and silently carry only its first (length MOD 256) characters. TP3 strings are at most 255 characters. *) Err (EConstRange) ; RETURN 0 END ; IF len + 1 <= 127 THEN Ebyte (0EBH) ; Ebyte (VAL (BYTE, len + 1)) (* JMP rel8 over it *) ELSE Ebyte (0E9H) ; Eword (len + 1) (* JMP rel16 over it *) END ; here := pc ; (* the length byte: the literal's address *) Ebyte (VAL (BYTE, len)) ; n := 0 ; WHILE n < len DO Ebyte (VAL (BYTE, ORD (strPool [strOff [r.strx] + n]))) ; INC (n) END ; RETURN here END EmStrBlob ; PROCEDURE EmPushSetAddr (r : ERes) ; (* Push the ADDRESS of a set value: the runtime's set entries take addresses. A set literal/typed constant is code-resident (kind 7), a set-expression result is a data buffer (kind 8), a named set is symbol+boff, and a field reached through DI is already addressed. *) BEGIN IF r.kind = 5 THEN EmPushDi () ELSIF r.kind = 1 THEN EmPushVarAddr (symtab [r.idx].local, (symtab [r.idx].off + r.boff) MOD 10000H) ELSIF (r.kind = 7) OR (r.kind = 8) THEN EmPushVarAddr (FALSE, r.setoff) ELSE Err (ENoLib) END END EmPushSetAddr ; PROCEDURE SetPairSize (left, right : ERes ; VAR size, base : CARDINAL) : BOOLEAN ; (* The byte count for a set operation. An inline literal is a 32-byte `set of Char' by default; when the other operand is a typed set (CALC's one-byte `set of Attributes') that type wins. Two non-literals must have the same origin and are taken at the smaller size; the runtime only ever touches that many bytes. *) BEGIN IF left.setbase # right.setbase THEN RETURN FALSE END ; base := left.setbase ; IF left.kind = 7 THEN IF right.kind = 7 THEN size := left.setsize ELSE size := right.setsize END ELSIF right.kind = 7 THEN size := left.setsize ELSE size := left.setsize ; IF right.setsize < size THEN size := right.setsize END END ; RETURN (size > 0) AND (size <= 32) END SetPairSize ; PROCEDURE AllocSetScratch (size : CARDINAL) : CARDINAL ; (* A fresh data buffer for one set expression. One per operation, so a nested or repeated expression cannot overwrite the other side while it is still being consumed. The bytes need no initialisation: every operation writes all `size' of them before the value is read. *) VAR off : CARDINAL ; BEGIN IF dc + size > 0F000H THEN Err (EConstRange) ; RETURN 0 END ; off := dc ; dc := dc + size ; RETURN off END AllocSetScratch ; PROCEDURE SetBinEmit (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ; (* The caller has already pushed the LEFT address (before parsing the right operand, so a DI-addressed field survives). Finish the argument list - right, destination, (op<<8)|size - call the runtime, and return the buffer as a kind-8 set value. *) VAR size, base, dest : CARDINAL ; BEGIN IF NOT SetPairSize (left, right, size, base) THEN Err (ENoLib) ; RETURN END ; dest := AllocSetScratch (size) ; IF NOT OK () THEN RETURN END ; EmPushSetAddr (right) ; EmPushVarAddr (FALSE, dest) ; EmMovAxi (W16 (op * 256 + size)) ; EmPushAx () ; DropC (EmCall (TU_SetOp)) ; EmAddSp (8) ; res.kind := 8 ; res.cls := TSet ; res.chr := FALSE ; res.setoff := dest ; res.setbase := base ; res.setsize := size END SetBinEmit ; PROCEDURE EmPushStrAddr (r : ERes) ; (* Push the ADDRESS of a whole-string operand - the argument shape cmpstr takes, one per operand. A string VARIABLE's value already is its address, so this is the same push READ makes (EmPushVarAddr), through symtab's local/off. A string LITERAL has no storage, and the image carries no initialised data to put one in (globals are left to the loader's zero fill), so the characters have to travel in the code stream and the operand is the address of those bytes. TP3 does the same in TPSRC9 fullvar (993): it builds the `JMP' opcode in AL and the length in AH (`MOV AL,#$EB' / `MOV.B AH,CH'), emits that word, and takes the position immediately after it as varofs, with varseg := CS - the instruction stream steps over the constant instead of running into it. The difference is one byte, and it is deliberate. TP3's constant is an ARRAY [1..n] OF CHAR, and `estr2' (TPSRC10 85) emits it WITHOUT a length byte because the length travelled on the stack instead. Every string in THIS runtime - variable or literal - is a `string': a length byte and then the characters, which is what rdstr writes and what cmpstr reads. So a literal operand has to look the same, and the jump carries one extra byte: , with the ADDRESS pushed being the length byte itself. The jump still exists only to keep the CPU from walking into the characters. Nothing is added to the data segment and no runtime entry is involved in reading the literal; LEA AX,[that] is absolute into the code segment, which is where a .COM's DS already is. A 1-character literal is NOT a TString here: RdConst reports it as TScalar (its character code), so `s = 'a'` compares a string with a character and is a type error rather than a length-1 string compare. That is deliberate - it is the same rule `c := 'a'` relies on - and the caller rejects it. *) BEGIN IF r.kind = 5 THEN (* a string element/field computed through DI - `Sheet[X,Y].Contents' and the `with' form. DI holds the field's address, which is exactly what cmpstr/strcat/strstore take on the stack, so push it. This used to be ENoLib, and it was the CALC rung after Write(Value:FW:DEC): `if Sheet[UFX,UFY].Contents <> '' then'. *) EmPushDi () ELSIF r.kind = 1 THEN EmPushVarAddr (symtab [r.idx].local, (symtab [r.idx].off + r.boff) MOD 10000H) ELSIF r.kind = 3 THEN EmPushVarAddr (FALSE, EmStrBlob (r)) (* the literal travels inline *) ELSE Err (ENoLib) (* a computed string is not a value *) END END EmPushStrAddr ; PROCEDURE EmPushStrSlot (r : ERes ; reserve, copyN : CARDINAL) ; (* Push a STRING VALUE argument's whole slot: reserve `reserve' bytes on the stack and copy `copyN' of the source string's into them, so that after the CALL the callee's BP+4 is the length byte and the characters follow it. ; local/global/literal alike SUB SP,reserve ; MOV DI,SP ; MOV CX,copyN loop: MOV AL,[SI] ; MOV [DI],AL ; INC SI ; INC DI ; LOOP loop The address comes from EmPushStrAddr, which already knows how to form it for a local ([BP+off]), a global (absolute) or a literal (inline blob) - so a caller's LOCAL string can be passed too, not just a global. A byte loop, not REP MOVSB, on purpose: MOVS/STOS address through ES, and a .COM's ES happens to equal DS but nothing in this compiler establishes that contract. Every access here is DS-relative, which is the one segment the image already guarantees. `copyN' is at most `reserve' (a shorter actual string than the formal leaves the tail of the slot untouched, harmless because the length byte bounds every read). *) BEGIN EmPushStrAddr (r) ; (* push the source address *) EmPopSi () ; (* SI := source *) EmSubSp (reserve) ; Ebyte (89H) ; Ebyte (0E7H) ; (* MOV DI,SP *) EmMovCxi (copyN) ; IF copyN > 0 THEN Ebyte (8AH) ; Ebyte (04H) ; (* MOV AL,[SI] *) Ebyte (88H) ; Ebyte (05H) ; (* MOV [DI],AL *) Ebyte (46H) ; (* INC SI *) Ebyte (47H) ; (* INC DI *) Ebyte (0E2H) ; Ebyte (0F8H) (* LOOP -8: back to MOV AL,[SI] *) END END EmPushStrSlot ; (* ---------------------------------------------------------------- *) (* sets - type sizing, literals, compile-time membership *) (* ---------------------------------------------------------------- *) PROCEDURE SetRangeBits (VAR bytes : ARRAY OF CHAR ; size, base : CARDINAL ; lo, hi : LONGINT) ; (* Set the bits for every element in [lo, hi], using TP3's hybrid rule (coeur-tp-ocr 4.7.2): element e is bit (e MOD 8) of byte ((e DIV 8) - (base DIV 8)), and is IGNORED unless that byte is in [0, size). A value that lands outside the used bytes is truncated away, as TP3 does; one inside them but outside the DECLARED range still lands, which is also TP3's behaviour. *) VAR rel, first, last, bidx, bit, m, o : CARDINAL ; BEGIN IF (hi < 0) OR (lo > 255) THEN RETURN END ; IF lo < 0 THEN first := 0 ELSE first := VAL (CARDINAL, lo) END ; IF hi > 255 THEN last := 255 ELSE last := VAL (CARDINAL, hi) END ; rel := first ; WHILE rel <= last DO IF rel >= base THEN bidx := (rel - base) DIV 8 ; IF bidx < size THEN bit := (rel - base) MOD 8 ; m := 1 ; WHILE bit > 0 DO m := m * 2 ; DEC (bit) END ; o := ORD (bytes [bidx]) ; IF (o DIV m) MOD 2 = 0 THEN bytes [bidx] := CHR (o + m) END END END ; INC (rel) END END SetRangeBits ; PROCEDURE RdSetLiteral (base, size : CARDINAL ; VAR bytes : ARRAY OF CHAR) : BOOLEAN ; (* Read a set constructor `[e, a..b, ...]' and fill `bytes' (already size long). `[]' is the empty set. *) VAR v, hi : LONGINT ; subcls : CARDINAL ; strf : BOOLEAN ; k : CARDINAL ; BEGIN k := 0 ; WHILE k < size DO bytes [k] := CHR (0) ; INC (k) END ; ExpectDelim ('[', ENoSemi) ; IF MatchDelim (']') THEN RETURN OK () (* [] - the empty set *) END ; LOOP RdConst (v, subcls, strf) ; IF strf THEN Err (ETypeErr) ; RETURN FALSE END ; IF MatchRange () THEN RdConst (hi, subcls, strf) ; IF strf THEN Err (ETypeErr) ; RETURN FALSE END ELSE hi := v END ; SetRangeBits (bytes, size, base, v, hi) ; IF MatchDelim (',') THEN (* another element *) ELSE EXIT END END ; ExpectDelim (']', ENoSemi) ; RETURN OK () END RdSetLiteral ; PROCEDURE EmSetBlob (VAR bytes : ARRAY OF CHAR ; size : CARDINAL) : CARDINAL ; (* Emit a set's bytes into the code stream behind a JMP over them - the same trick EmPushStrAddr uses for a string literal - and return the image offset of the first byte. Nothing goes in the data segment: a .COM's DS already covers the code segment, which is why this port needs no `seg cs' where the original did (see CALC-COMPILE.md's typed-constant storage decision). *) VAR here, k : CARDINAL ; BEGIN IF size + 2 <= 127 THEN Ebyte (0EBH) ; Ebyte (VAL (BYTE, size)) (* JMP rel8 over it *) ELSE Ebyte (0E9H) ; Eword (size) (* JMP rel16 over it *) END ; here := pc ; k := 0 ; WHILE k < size DO Ebyte (VAL (BYTE, ORD (bytes [k]))) ; INC (k) END ; RETURN here END EmSetBlob ; PROCEDURE FoldSetIn (left, right : ERes ; VAR res : ERes) ; (* `e IN s' where e is a compile-time ordinal and s a set whose bytes are already in the image: answer at compile time, exactly as TPSRC2's xsetin answers at run time (AH > 255 -> FALSE, else test the bit). A run-time element or a run-time set is still ENoLib - that is the next milestone, and it must stay LOUD rather than silently answer wrong. *) VAR off, base, size, rel, bidx, bit, m, o : CARDINAL ; isIn, foldable : BOOLEAN ; jl, jg, jmp : CARDINAL ; BEGIN res.kind := 0 ; res.imm := 0 ; res.cls := TBool ; res.chr := FALSE ; IF right.cls # TSet THEN Err (ENoLib) ; RETURN END ; IF left.kind # 0 THEN (* A RUN-TIME element (`Upcase(Ch) in ['Y','N']', `Ch in ['a'..'z']'). Materialise it in AX, subtract the set's base, reject the out-of-range values with the two signed tests the compiler declares (L and G), then index the bit array: byte = (e-base) DIV 8, bit = (e-base) MOD 8. The set's address is formed according to where its bytes live: an inline literal or typed constant is code-resident (image offset + LoadBias), a data set is an absolute or BP-relative address. A set already addressed through DI and an element that itself needs DI are refused: the address would be lost. *) IF right.kind = 5 THEN Err (ENoLib) ; RETURN END ; LoadAtom (left) ; IF NOT OK () THEN RETURN END ; IF right.setbase # 0 THEN EmMovCxi (W16 (right.setbase)) ; EmSubAxCx () END ; EmCmpAxi (0) ; jl := EmJcc (8CH, 0) ; (* JL -> false *) EmCmpAxi (W16 (right.setsize * 8)) ; jg := EmJcc (8FH, 0) ; (* JG -> false *) EmMovClAl () ; EmAndClImm (7) ; EmShrAx1 () ; EmShrAx1 () ; EmShrAx1 () ; (* AX := byte index *) IF right.kind = 7 THEN EmMovBxi (W16 (right.setoff + LoadBias)) ELSIF right.kind = 1 THEN IF symtab [right.idx].local THEN EmLeaBx ((right.setoff + right.boff) MOD 10000H) ELSE EmMovBxi ((right.setoff + right.boff + LoadBias) MOD 10000H) END ELSE Err (ENoLib) ; RETURN END ; EmAddBxAx () ; (* BX := the set's byte *) EmLdAlBx () ; EmMovDlImm (1) ; EmShlDlCl () ; (* DL := 1 << bit *) EmAndAlDl () ; EmMovAh0 () ; EmOrAxAx () ; EmRelSetcc (2) ; (* SETNE: the bit was set *) jmp := EmJmpNear (0) ; SetPatTgt (jl, pc) ; SetPatTgt (jg, pc) ; EmMovAxi (0) ; SetPatTgt (jmp, pc) ; res.kind := 2 ; res.cls := TBool ; RETURN END ; (* A code-resident set (an inline literal or a typed constant) folds at compile time. A DATA set - a record field, local or global, or one addressed through DI - must be tested at run time: its byte is in the image's data area, not in cbuf. A typed constant's offset is below dataBase; a global's is at or above it. *) foldable := (right.kind = 7) ; IF (right.kind = 1) AND NOT symtab [right.idx].local AND (right.setoff + right.boff < dataBase) THEN foldable := TRUE END ; IF NOT foldable THEN IF (left.imm >= 0) AND (left.imm <= 255) THEN base := right.setbase ; size := right.setsize ; rel := VAL (CARDINAL, left.imm) ; IF rel >= base THEN bidx := (rel - base) DIV 8 ; IF bidx < size THEN bit := (rel - base) MOD 8 ; m := 1 ; WHILE bit > 0 DO m := m * 2 ; DEC (bit) END ; IF right.kind = 5 THEN EmLdAlDiOff (bidx) ELSIF right.kind = 1 THEN EmLoadVar (symtab [right.idx].local, (right.setoff + right.boff + bidx) MOD 10000H, 1) ELSE Err (ENoLib) ; RETURN END ; EmAndAlImm (m) ; EmMovAh0 () ; EmOrAxAx () ; EmRelSetcc (2) ; (* SETNE: the bit was set *) res.kind := 2 ; res.cls := TBool ; RETURN END END END ; res.imm := 0 ; RETURN END ; isIn := FALSE ; IF (left.imm >= 0) AND (left.imm <= 255) THEN off := right.setoff ; base := right.setbase ; size := right.setsize ; rel := VAL (CARDINAL, left.imm) ; IF rel >= base THEN bidx := (rel - base) DIV 8 ; IF bidx < size THEN bit := (rel - base) MOD 8 ; m := 1 ; WHILE bit > 0 DO m := m * 2 ; DEC (bit) END ; o := VAL (CARDINAL, cbuf [off + bidx]) ; isIn := (o DIV m) MOD 2 # 0 END END END ; res.imm := ORD (isIn) END FoldSetIn ; PROCEDURE RdSetBase (VAR baseCls : CARDINAL ; VAR lo, hi : LONGINT) ; (* The base type of `set of ...': an ordinal range. `Char' and `byte' are 0..255; a literal subrange `a..b' is read directly. A named or enumerated base is ENoLib for now - `set of Attributes' waits for enums. *) VAR idx, subcls : CARDINAL ; strf : BOOLEAN ; BEGIN baseCls := TScalar ; Skip () ; IF Alpha (CurCh ()) THEN GetWord () ; IF Search (wrd, idx) AND (symtab [idx].tag = KType) THEN IF symtab [idx].cls = TEnum THEN lo := symtab [idx].lo ; hi := symtab [idx].hi ; baseCls := TEnum ELSIF (symtab [idx].cls = TChar) OR ((symtab [idx].cls = TScalar) AND (symtab [idx].size = 1)) THEN lo := 0 ; hi := 255 ; baseCls := symtab [idx].cls ELSE Err (ENoLib) END ELSE Err (EUnknown) END ELSE RdConst (lo, subcls, strf) ; IF NOT MatchRange () THEN Err (ESimpType) ; RETURN END ; RdConst (hi, subcls, strf) ; IF (lo < 0) OR (hi > 255) OR (lo > hi) THEN Err (EConstRange) END END END RdSetBase ; PROCEDURE NewScratchStr () : CARDINAL ; (* Allocate a fresh 256-byte global STRING and return its symbol index. A concatenation result needs STORAGE the emitted code can name. Making the result a string VARIABLE (kind 1) is what keeps every downstream consumer untouched: Assignment, IoCall and ParseCmp already handle kind 1, so `s := a + b', `writeln(a + b)' and `(a + b) = c' work with no code of their own. One scratch PER `+' in the source, so a repeated or nested concatenation never shares a destination - `a + b + c' is two occurrences and gets two scratch strings, and the first result survives until the second consumes it. (A loop reuses its site's scratch, which is correct because each execution writes before it reads.) Recursion would break that, but this compiler compiles no procedures yet - see the item list. 256 bytes is the STRING type's own size, length byte plus 255 characters: see ParseType's TkString arm and the predefined STRING in Inittur. The name is a placeholder (nothing looks a scratch up by name) spelled with '@', as tmpA/tmpB are, so it cannot collide with a Modula-2 identifier. *) BEGIN DropC (NewSym ("@@SC", KVar, TString, 256, 1, dc, 0, FALSE)) ; dc := dc + 256 ; RETURN symTop - 1 END NewScratchStr ; PROCEDURE StrOperand (r : ERes) : BOOLEAN ; (* Is r usable as one operand of `+'? A STRING, or a CHAR - which can appear three ways: a quoted literal (cls TScalar with chr set), a CHAR variable (cls TChar), and a string element s[i] (cls TChar, kind 5). A number is not, and neither is a BOOLEAN. *) BEGIN RETURN (r.cls = TString) OR (r.cls = TChar) OR ((r.cls = TScalar) AND r.chr) END StrOperand ; PROCEDURE EmPushStrOperand (r : ERes) ; (* Push the ADDRESS of one concatenation operand, converting a CHAR to a length-1 string first. A STRING operand is pushed exactly as cmpstr pushes one (EmPushStrAddr): a variable's value already IS its address, and a literal travels inline. A CHAR operand has no such address, so it is materialised as a `' string in a fresh 2-byte scratch and the address of THAT is pushed. This is TPSRC9's addch/addch2, which splice a character into a concatenation by building a one-character string. The character is loaded into AL (LoadAtom), the character is stored at [coff+1] and the length 1 at [coff]. At most one operand of a concatenation is a CHAR - StrConcat rejects char+char - so at most one such scratch is ever made. *) VAR coff : CARDINAL ; BEGIN IF r.cls = TString THEN EmPushStrAddr (r) ELSE coff := dc ; dc := dc + 2 ; LoadAtom (r) ; (* AX := the character *) EmStoreVar (FALSE, (coff + 1) MOD 10000H, 1) ; (* [coff+1] := AL *) EmMovAxi (1) ; (* AX := 1 *) EmStoreVar (FALSE, coff MOD 10000H, 1) ; (* [coff] := AL = length *) EmPushVarAddr (FALSE, coff MOD 10000H) END END EmPushStrOperand ; PROCEDURE StrConcat (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ; (* `left + right' for strings: TPSRC2's xconcat, emitted as two runtime calls. The layout is `' and `+' needs a place to build its result, so this allocates one 256-byte global scratch (NewScratchStr) and copies into it: first `dest := left' through the runtime's strstore, then `dest := dest + right' through strcat, which appends. Using strstore for the left operand and strcat for the right keeps the append logic in one place and gives the compiler exactly one new entry to reach; it also means the two calls have the same argument shape (source pushed first, destination last, limit in CX), so the emission differs only in the entry named. The limit is 255 - the scratch's 255 usable characters. An overflowing result is a RUNTIME ERROR with exit code 16, TP3's `String too long', not a truncation; see Runtime.EmitStrCat. The operator rule: `+' concatenates, anything else over a STRING is a type error, and char+char is ALSO a type error. ISO Modula-2 gives no meaning to two characters summed, and inventing one (a two-character string?) would be a guess this compiler does not make; TP3's own behaviour there is not something the reference pins down. That char+char choice is the one place this differs from a literal reading of the reference, and it is recorded here and in v-TP3-STRCAT.md rather than left to be discovered. The guard below is what ENFORCES that rule, and it only runs because BinOpEmit's hook routes a CHAR operand here too. A hook that tested for a STRING operand only would send `'a' + 'b'' to the integer path instead and this test would never be reached - which is exactly what it did until t53_strcat_type caught it. Three ways to fail it: a non-`+' operator over a string operand, an operand that is neither a string nor a CHAR (a number), and two CHARs with no STRING on either side. *) VAR dest : CARDINAL ; BEGIN (* A placeholder for the paths below that bail out through Err. Err only records the first error and does not unwind, so the caller goes on to use res regardless: after `Err (ETypeErr)' in the guard, ParseAdd hands res straight back to IoCall, to Assignment or to an enclosing concatenation. The placeholder's SHAPE therefore matters. It must not claim to be a STRING, because the string consumers reach symtab[res.idx] for any TString (IoCall's `writeln' arm does) and idx is not a symbol here; and it must be something LoadAtom can fold, because the numeric consumers will try. The integer 0 is both. Leaving kind-2/TString here, as this once did, turned `writeln('a' + 'b')' - two CHARs, a type error - into a compiler segfault instead of an error message. *) res.kind := 0 ; res.imm := 0 ; res.cls := TScalar ; res.boff := 0 ; res.chr := FALSE ; IF (op # OpAdd) OR NOT StrOperand (left) OR NOT StrOperand (right) OR ((left.cls # TString) AND (right.cls # TString)) THEN Err (ETypeErr) ; (* a STRING on the wrong operator, a number, or two CHARs *) RETURN END ; dest := NewScratchStr () ; (* dest := left *) EmPushStrOperand (left) ; EmPushVarAddr (FALSE, (symtab [dest].off) MOD 10000H) ; EmMovCxi (255) ; DropC (EmCall (TU_StrStore)) ; EmAddSp (4) ; (* pop the two addresses strstore took *) (* dest := dest + right *) EmPushStrOperand (right) ; EmPushVarAddr (FALSE, (symtab [dest].off) MOD 10000H) ; EmMovCxi (255) ; DropC (EmCall (TU_StrCat)) ; EmAddSp (4) ; res.kind := 1 ; res.idx := dest ; res.cls := TString ; res.boff := 0 ; res.chr := FALSE END StrConcat ; PROCEDURE ParseCmp (VAR r : ERes) ; (* "=" | "<>" | "<" | "<=" | ">" | ">=" *) VAR op : CARDINAL ; left, right : ERes ; f : LONGINT ; size, base : CARDINAL ; 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 IF KwAhead ("IN") THEN (* `e IN s' is at the comparison level in TP3 (TPSRC9 cmpin, 116). Only the compile-time case is implemented; see FoldSetIn. *) GetWord () ; left := r ; ParseAdd (right) ; FoldSetIn (left, right, r) ; RETURN END ; RETURN END ; left := r ; IF left.cls = TSet THEN (* Set comparison. set_cmp returns a mask (bit 0 equal, bit 1 strict subset, bit 2 strict superset); the operator selects which bits answer it, and the shared EmRelSetcc arm turns the flags into a boolean. The left address is pushed before the right operand is parsed, for the same DI reason as strings and set arithmetic. *) EmPushSetAddr (left) ; ParseAdd (right) ; IF NOT OK () THEN RETURN END ; IF right.cls # TSet THEN Err (ETypeErr) ; RETURN END ; IF NOT SetPairSize (left, right, size, base) THEN Err (ENoLib) ; RETURN END ; EmPushSetAddr (right) ; EmMovAxi (size) ; EmPushAx () ; DropC (EmCall (TU_SetCmp)) ; EmAddSp (4) ; CASE op OF 1 : EmMovCxi (1) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ; | 2 : EmMovCxi (1) ; EmAndAxCx () ; EmXorAl01 () ; EmOrAxAx () ; EmRelSetcc (2) ; | 3 : EmMovCxi (2) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ; | 4 : EmMovCxi (4) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ; | 5 : EmMovCxi (5) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ; | 6 : EmMovCxi (3) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) END ; r.kind := 2 ; r.cls := TBool ELSIF left.cls = TString THEN (* A string comparison: cmpstr, the entry TPSRC9's vcompare (133) reaches through TPSRC2's csteq/cstne/cstge/cstle/cstg/cstl wrappers (890-925). The operands are pushed as ADDRESSES, before the right-hand parse can clobber DI. This is why the left is pushed here rather than through SaveLeft: a kind-5 left is a string FIELD whose address is in DI, and SaveLeft's job is to materialise a scalar in AX, which would read the length byte as a number (or, for a whole string, refuse it). `if Sheet[UFX,UFY].Contents <> '' then' was exactly that: the CALC rung after Write(Value:FW:DEC). cmpstr returns AX = -1/0/+1 (see Runtime.mod for why a value and not flags), so the second half is exactly the numeric arm's: put the sign in the flags and let the shared six-arm table answer. EmOrAxAx is OR AX,AX rather than EmCmpAxi(0) on purpose: tests/ check_8086.py reads every `CMP AX,0000' in the program region as an IF/WHILE/REPEAT test and requires a branch right after it, and a comparison used as a VALUE (writeln(a = b)) is not one. *) EmPushStrAddr (left) ; ParseAdd (right) ; IF right.cls # TString THEN Err (ETypeErr) ; (* a string compared with a number/char *) RETURN END ; EmPushStrAddr (right) ; DropC (EmCall (TU_CmpStr)) ; EmAddSp (4) ; EmOrAxAx () ; EmRelSetcc (op) ; r.kind := 2 ; r.cls := TBool ELSE SaveLeft (left) ; ParseAdd (right) ; IF (right.cls = TString) OR (right.cls = TSet) THEN Err (ETypeErr) ; (* a number compared with a string/set *) RETURN END ; 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 LoadPair (left, right) ; EmCmpAxCx () ; EmRelSetcc (op) ; r.kind := 2 ; r.cls := TBool END 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 ; IF left.cls = TSet THEN (* Set union/difference. The left address goes on the stack BEFORE the right is parsed: a DI-addressed set field must survive the right-hand expression. `OR' is boolean, not set union. *) IF (op = OpAdd) OR (op = OpSub) THEN EmPushSetAddr (left) ; ParseMul (right) ; IF NOT OK () THEN RETURN END ; IF right.cls # TSet THEN Err (ETypeErr) ; RETURN END ; IF op = OpAdd THEN SetBinEmit (1, left, right, r) ELSE SetBinEmit (2, left, right, r) END ELSE Err (ETypeErr) ; RETURN END ELSE SaveLeft (left) ; ParseMul (right) ; IF NOT OK () THEN RETURN END ; IF right.cls = TSet THEN Err (ETypeErr) ; RETURN END ; BinOpEmit (op, left, right, r) END 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 ; IF left.cls = TSet THEN (* Set intersection. Same push-before-the-right rule as ParseAdd. *) IF op = OpMul THEN EmPushSetAddr (left) ; ParseNeg (right) ; IF NOT OK () THEN RETURN END ; IF right.cls # TSet THEN Err (ETypeErr) ; RETURN END ; SetBinEmit (0, left, right, r) ELSE Err (ETypeErr) ; RETURN END ELSE SaveLeft (left) ; ParseNeg (right) ; IF NOT OK () THEN RETURN END ; IF right.cls = TSet THEN Err (ETypeErr) ; RETURN END ; BinOpEmit (op, left, right, r) END 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) ; (* TPSRC9 neglevel branches on the operand's type before emitting anything: CMP CL,#$0A (integer) -> NOT AX, CMP CL,#$0B (boolean) -> XOR AL,#01, anything else -> error. This used to emit NOT AX for both, so `not (a = a)' produced 0FFFEh and the runtime's wrbool test ([BP+4] <> 0) read it as TRUE. The integer constant fold stays: the 16 bits are the same either way. A boolean constant must not go through BitNot - 0FFFFH-1 is 0FFFEh, which wrbool also reads as TRUE - so it is loaded and xor-ed, exactly as neglevel does it. *) IF r.cls = TBool THEN LoadAtom (r) ; EmXorAl01 () ; r.kind := 2 ELSIF r.cls = TScalar THEN IF r.kind = 0 THEN r.imm := BitNot (r.imm) ELSE LoadAtom (r) ; EmNotAx () ; r.kind := 2 END ELSE Err (ETypeErr) END ; RETURN END ; ParseAtom (r) END ParseNeg ; PROCEDURE WithLookup (nm : ARRAY OF CHAR ; VAR r : ERes) : BOOLEAN ; (* Resolve a bare identifier against the active WITH scopes, innermost first. ISO Pascal lets a record field shadow an outer declaration, so this is consulted BEFORE Search. The result is filled exactly as a variable reference: kind 1 (base symbol + boff) for a record variable or a constant-index element, kind 5 (address in DI) for a run-time-indexed one, where the base is reloaded from the WITH slot because the body may have used DI. *) VAR w, fi : CARDINAL ; found : BOOLEAN ; BEGIN w := withN ; WHILE w > 0 DO DEC (w) ; fi := withFF [w] ; found := FALSE ; WHILE (fi < withFL [w]) AND NOT found DO IF NameEq (fields [fi].name, nm) THEN found := TRUE ELSE INC (fi) END END ; IF found THEN IF withIsDI [w] THEN EmLdDiGlob (withSlot [w]) ; IF fields [fi].off # 0 THEN EmAddDiImm (fields [fi].off) END ; r.kind := 5 ELSE r.kind := 1 ; r.setoff := symtab [withIdx [w]].off ; r.boff := W16 (VAL (LONGINT, withBoff [w]) + VAL (LONGINT, fields [fi].off)) END ; r.idx := withIdx [w] ; r.cls := fields [fi].cls ; r.sz := fields [fi].size ; IF r.cls = TSet THEN r.setbase := fields [fi].elem ; r.setsize := fields [fi].size END ; r.chr := FALSE ; RETURN TRUE END END ; RETURN FALSE END WithLookup ; PROCEDURE ParseAtom (VAR r : ERes) ; (* const | variable | func(params) | '(' expr ')' | '[' set ']' *) VAR idx : CARDINAL ; strf : BOOLEAN ; quoted : BOOLEAN ; ssize, sbase : CARDINAL ; sbuf : ARRAY [0..31] OF CHAR ; uj1, uj2 : CARDINAL ; BEGIN r.chr := FALSE ; (* default: not a quoted char literal *) Skip () ; IF CurCh () = '(' THEN DropCh (GetCh ()) ; ParseExpr (r) ; ExpectDelim (')', ENoSemi) ; RETURN END ; IF CurCh () = '[' THEN (* An inline set literal. Full TP3 takes its type from context; here it defaults to `set of Char' (0..255), which is what CALC writes (`Ch in ['a'..'z']'), and its bytes are materialised in the code stream. A typed/larger-base literal is a later milestone. *) ssize := 32 ; sbase := 0 ; IF RdSetLiteral (sbase, ssize, sbuf) THEN r.kind := 7 ; r.cls := TSet ; r.setoff := EmSetBlob (sbuf, ssize) ; r.setbase := sbase ; r.setsize := ssize END ; RETURN END ; IF (CurCh () = '$') OR (Digit (CurCh ())) OR (ORD (CurCh ()) = AposC) OR (CurCh () = '^') OR (CurCh () = '#') 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. A caret (^M) or decimal (#27) character constant is a character too. *) quoted := (ORD (CurCh ()) = AposC) OR (CurCh () = '^') OR (CurCh () = '#') ; 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 WithLookup (wrd, r) THEN ParseSub (r) ; RETURN END ; 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 initialises boff to 0 and then ParseSub folds any constant subscript into it. Do NOT reset boff here: doing so after ParseVar returns threw away the subscript, so s[i] read/wrote off+0 (the length byte) while still reporting itself as a char. This was latent for arrays because an array cannot be declared yet, so no fixture had ever exercised the fold. *) ParseVar (r) ; RETURN ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_UpCase) THEN (* UpCase(c): a CHAR function. A constant folds; otherwise AL is mapped 'a'..'z' -> 'A'..'Z' and left alone outside that range. The test is JL/JG (signed), which is the same answer for 0..127 chars and leaves 128..255 unchanged; it also stays inside the four branch conditions this compiler declares (check_8086's set). *) IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ; ParseExpr (r) ; ExpectDelim (')', ENoSemi) ; IF NOT OK () THEN RETURN END ; IF (r.cls # TChar) AND (r.cls # TScalar) THEN Err (ETypeErr) ; (* the STRING form is not implemented *) RETURN END ; IF r.kind = 0 THEN IF (r.imm >= VAL (LONGINT, ORD ('a'))) AND (r.imm <= VAL (LONGINT, ORD ('z'))) THEN r.imm := r.imm - 32 END ; r.kind := 0 ; r.cls := TChar ; r.chr := TRUE ; RETURN END ; LoadAtom (r) ; EmCmpAlImm (ORD ('a')) ; uj1 := EmJcc (8CH, 0) ; (* JL -> leave it *) EmCmpAlImm (ORD ('z')) ; uj2 := EmJcc (8FH, 0) ; (* JG -> leave it *) EmSubAlImm (32) ; SetPatTgt (uj1, pc) ; SetPatTgt (uj2, pc) ; EmMovAh0 () ; r.kind := 2 ; r.cls := TChar ; r.chr := FALSE ; RETURN ELSIF (symtab [idx].tag = KBuiltin) AND ((symtab [idx].cls = BI_Succ) OR (symtab [idx].cls = BI_Pred)) THEN (* Succ(x) / Pred(x) on an ordinal. CALC's `FX := Succ(FX)' is the first use. A constant folds; otherwise load the value and INC/DEC it, preserving the operand's class so an assignment back to a CHAR subrange stores one byte as before. *) IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ; ParseExpr (r) ; ExpectDelim (')', ENoSemi) ; IF NOT OK () THEN RETURN END ; IF (r.cls # TChar) AND (r.cls # TScalar) THEN Err (ETypeErr) ; RETURN END ; IF r.kind = 0 THEN IF symtab [idx].cls = BI_Succ THEN r.imm := VAL (LONGINT, W16 (r.imm + 1)) ELSE r.imm := VAL (LONGINT, W16 (r.imm - 1)) END ELSE LoadAtom (r) ; IF symtab [idx].cls = BI_Succ THEN EmIncAx () ELSE EmDecAx () END ; r.kind := 2 END ; r.chr := FALSE ; RETURN ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_KeyPressed) THEN (* KeyPressed: a boolean FUNCTION with no argument, and TP3 lets it be written without a parameter list (`until KeyPressed'). *) EmCrtSeq (CrtKey) ; r.kind := 2 ; r.cls := TBool ; r.chr := FALSE ; RETURN ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Length) THEN (* LENGTH (s): the string's length byte, loaded inline. No runtime entry, and no address is pushed - a string's value already carries its length at [addr]. A literal is emitted inline (EmStrBlob) and the byte is read from that image offset. *) IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ; ParseExpr (r) ; ExpectDelim (')', ENoSemi) ; IF NOT OK () THEN RETURN END ; IF r.cls # TString THEN Err (ETypeErr) ; RETURN END ; IF r.kind = 1 THEN EmLoadVar (symtab [r.idx].local, (symtab [r.idx].off + r.boff) MOD 10000H, 1) ELSIF r.kind = 3 THEN EmLoadVar (FALSE, EmStrBlob (r), 1) ELSE Err (ENoLib) ; RETURN END ; EmMovAh0 () ; r.kind := 2 ; r.cls := TScalar ; r.chr := FALSE ; 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 ParmSlot (idx, k : CARDINAL) : CARDINAL ; (* The stack slot of argument k (0-based) of procedure/function idx, from the parameter list recorded on the symbol. Out of range means the source passed more arguments than there are parameters: keep the old two-byte assumption rather than inventing an arity error here. *) VAR pi : CARDINAL ; BEGIN IF (symtab [idx].parmCount = 0) OR (k >= symtab [idx].parmCount) THEN RETURN 2 END ; pi := symtab [idx].parmFirst + k ; RETURN ParamSlotBytes (symtab [pi]) END ParmSlot ; PROCEDURE ParmIsVar (idx, k : CARDINAL) : BOOLEAN ; (* Is argument k (0-based) of procedure/function idx declared VAR? Out of range means the source passed more arguments than there are formals; treat it as a value parameter, as ParmSlot already does. *) VAR pi : CARDINAL ; BEGIN IF (symtab [idx].parmCount = 0) OR (k >= symtab [idx].parmCount) THEN RETURN FALSE END ; pi := symtab [idx].parmFirst + k ; RETURN symtab [pi].isVar END ParmIsVar ; PROCEDURE EmCallMost (idx, cleanup : CARDINAL) ; (* emit the call to sym 'idx' and clean up `cleanup' bytes of arguments, which is the SUM of their slot sizes - not 2 per argument once a slot can be larger than a word. *) VAR p : CARDINAL ; BEGIN IF symtab [idx].defnd THEN DropC (EmCall (symtab [idx].goPos)) ELSE p := EmCall (0) ; AddPend (1, idx, p) END ; IF cleanup > 0 THEN EmAddSp (cleanup) END END EmCallMost ; PROCEDURE ParseCallArgs (idx : CARDINAL) ; (* '(' already consumed: read args ')' then call. Each argument is loaded and pushed the moment it has been parsed, which is what TPSRC8 cproc/cprlp1/cprlp2 do - CALL exprsave, CALL epushax, one per argument, then the CALL. A computed argument (kind 2) exists only in AX, so parsing the argument after it would destroy it before the push loop ever reached it: `p (a > b, x)' passed x twice. Pushing in parse order is also the order the callee is laid out for: the first argument goes on first and so ends up farthest from BP, and the LAST declared parameter is the one at BP+4 (RESUME-TP3.md 3.11). *) VAR arg : ERes ; nArgs, cleanup, slot, nCopy : CARDINAL ; BEGIN nArgs := 0 ; cleanup := 0 ; IF CurCh () = ')' THEN DropCh (GetCh ()) ELSE LOOP IF nArgs >= 16 THEN Err (ECompOvf) ; EXIT END ; ParseExpr (arg) ; slot := ParmSlot (idx, nArgs) ; IF ParmIsVar (idx, nArgs) THEN (* VAR formal: push the actual's ADDRESS. Only a variable has one; a constant or a computed value is refused rather than quietly passed by value. An element with a constant index (`s[i]') is a variable too: its address is off+boff, which EmPushVarAddr forms directly. *) IF arg.kind # 1 THEN Err (ENoLib) ; EXIT END ; IF symtab [arg.idx].isVar THEN (* Passing a VAR parameter on: its slot already HOLDS the address, so push that, not the address of the slot. *) IF arg.boff # 0 THEN Err (ENoLib) ; EXIT END ; EmLoadVar (TRUE, symtab [arg.idx].off, 2) ; EmPushAx () ELSE EmPushVarAddr (symtab [arg.idx].local, (symtab [arg.idx].off + arg.boff) MOD 10000H) END ELSIF slot > 2 THEN (* A STRING VALUE parameter: push its whole slot, copied. `copyN' is at most the slot: an actual shorter than the formal leaves the tail untouched, which is harmless because the length byte bounds every read. *) IF arg.cls # TString THEN Err (ETypeErr) ; EXIT END ; nCopy := slot ; IF arg.kind = 1 THEN IF VarSize (arg) < nCopy THEN nCopy := VarSize (arg) END ELSIF arg.kind = 3 THEN IF strLen [arg.strx] + 1 < nCopy THEN nCopy := strLen [arg.strx] + 1 END ELSE Err (ENoLib) ; (* a computed string is not a value *) EXIT END ; EmPushStrSlot (arg, slot, nCopy) ELSE LoadAtom (arg) ; EmPushAx () END ; cleanup := cleanup + slot ; INC (nArgs) ; IF NOT MatchDelim (',') THEN EXIT END END ; ExpectDelim (')', ENoSemi) END ; EmCallMost (idx, cleanup) END ParseCallArgs ; PROCEDURE ParseCall (idx : CARDINAL) ; (* procedure/function call; '(' optional - same parse-then-push as above, reached from ParseAtom when a FUNCTION is called in an expression *) VAR arg : ERes ; nArgs, cleanup, slot, nCopy : CARDINAL ; BEGIN nArgs := 0 ; cleanup := 0 ; IF MatchDelim ('(') THEN IF CurCh () # ')' THEN LOOP IF nArgs >= 16 THEN Err (ECompOvf) ; EXIT END ; ParseExpr (arg) ; slot := ParmSlot (idx, nArgs) ; IF slot > 2 THEN (* see ParseCallArgs: push the whole string slot *) IF arg.cls # TString THEN Err (ETypeErr) ; EXIT END ; nCopy := slot ; IF arg.kind = 1 THEN IF VarSize (arg) < nCopy THEN nCopy := VarSize (arg) END ELSIF arg.kind = 3 THEN IF strLen [arg.strx] + 1 < nCopy THEN nCopy := strLen [arg.strx] + 1 END ELSE Err (ENoLib) ; EXIT END ; EmPushStrSlot (arg, slot, nCopy) ELSE LoadAtom (arg) ; EmPushAx () END ; cleanup := cleanup + slot ; INC (nArgs) ; IF NOT MatchDelim (',') THEN EXIT END END ; ExpectDelim (')', ENoSemi) ELSE DropCh (GetCh ()) END END ; EmCallMost (idx, cleanup) 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 IntToMbf (v : LONGINT ; VAR b : ARRAY OF CHAR) ; (* TP3's 6-byte Real, as measured in CALC-PORT.md against the cells holding 1, 2, 3, 4 and 5: value = (1 + N / 2^39) * 2^(E - 129) byte 0 is E (biased by 129); bytes 1..5 are N, little-endian; the SIGN is bit 7 of byte 5 (the book's `sign + 39-bit mantissa'). An all-zero value is 0.0. 1 -> 81 00 00 00 00 00, 3 -> 82 00 00 00 00 40, 5 -> 83 00 00 00 00 20 - all cross-checked against CALCDEMO.MCS. Only INTEGER values are converted; real arithmetic and formatting are a later stage, and a real RHS that is not a constant or a copy is ENoLib. *) VAR a, p, n : LONGINT ; e, k, i : CARDINAL ; neg : BOOLEAN ; BEGIN i := 0 ; WHILE i < 6 DO b [i] := CHR (0) ; INC (i) END ; IF v = 0 THEN RETURN END ; neg := v < 0 ; IF neg THEN a := -v ELSE a := v END ; (* k = floor(log2(a)); p = 2^k *) p := 1 ; k := 0 ; WHILE (k < 39) AND (p * 2 <= a) DO p := p * 2 ; INC (k) END ; IF k >= 39 THEN Err (EConstRange) ; RETURN END ; e := 129 + k ; b [0] := CHR (e) ; n := a - p ; i := 39 - k ; WHILE i > 0 DO n := n * 2 ; DEC (i) END ; i := 1 ; WHILE i <= 5 DO b [i] := CHR (VAL (CARDINAL, n MOD 256)) ; n := n DIV 256 ; INC (i) END ; IF neg THEN b [5] := CHR (ORD (b [5]) + 128) END END IntToMbf ; PROCEDURE Assignment (r : ERes) ; (* ':=' already consumed by the caller; store expression into r *) VAR src : ERes ; k, n : CARDINAL ; sbuf : ARRAY [0..31] OF CHAR ; rbuf : ARRAY [0..5] OF CHAR ; BEGIN IF (r.kind # 1) AND (r.kind # 5) THEN Err (EUnknown) ; RETURN END ; IF r.cls = TReal THEN (* A 6-byte REAL. A compile-time ordinal constant is converted to the measured MBF layout; another REAL field is copied byte for byte. Real arithmetic and real-valued expressions are a later stage and are refused, not guessed. *) ParseExpr (src) ; IF NOT OK () THEN RETURN END ; IF (src.kind = 0) AND (src.cls # TString) AND (src.cls # TSet) THEN IntToMbf (src.imm, rbuf) ; IF r.kind = 5 THEN k := 0 ; WHILE k < 6 DO EmStDiImm (k, ORD (rbuf [k])) ; INC (k) END ELSIF r.kind = 1 THEN k := 0 ; WHILE k < 6 DO EmMovAxi (ORD (rbuf [k])) ; EmStoreVar (symtab [r.idx].local, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ; INC (k) END ELSE Err (ENoLib) END ; RETURN END ; IF (src.kind = 1) AND (src.cls = TReal) THEN IF r.kind = 5 THEN IF src.kind = 5 THEN Err (ENoLib) ; RETURN END ; k := 0 ; WHILE k < 6 DO EmLoadVar (symtab [src.idx].local, (symtab [src.idx].off + src.boff + k) MOD 10000H, 1) ; EmStDiAlOff (k) ; INC (k) END ELSIF r.kind = 1 THEN k := 0 ; WHILE k < 6 DO EmLoadVar (symtab [src.idx].local, (symtab [src.idx].off + src.boff + k) MOD 10000H, 1) ; EmStoreVar (symtab [r.idx].local, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ; INC (k) END ELSE Err (ENoLib) END ; RETURN END ; Err (ENoLib) ; RETURN END ; IF r.cls = TSet THEN (* `field := [elements]'. The constructor's TYPE comes from the target: CALC's CellStatus is `set of Attributes' (one byte), not the default 32-byte `set of Char' an untyped literal would become. The bytes are known at compile time; store them at symbol+boff or through DI. *) IF (r.setsize = 0) OR (r.setsize > 32) THEN Err (ENoLib) ; RETURN END ; Skip () ; IF CurCh () # '[' THEN (* `set := set' or a set expression. The destination is a variable or a DI-addressed field; save the DI address BEFORE the right-hand expression can reuse DI, then copy the runtime's bytes. *) IF r.kind = 5 THEN EmPushDi () END ; ParseExpr (src) ; IF NOT OK () THEN RETURN END ; IF src.cls # TSet THEN Err (ETypeErr) ; RETURN END ; IF r.kind = 1 THEN EmPushVarAddr (symtab [r.idx].local, (symtab [r.idx].off + r.boff) MOD 10000H) ELSIF r.kind # 5 THEN Err (ENoLib) ; RETURN END ; EmPushSetAddr (src) ; n := r.setsize ; IF (src.kind = 8) AND (src.setsize < n) THEN n := src.setsize END ; EmMovAxi (n) ; EmPushAx () ; DropC (EmCall (TU_SetCopy)) ; EmAddSp (4) ; RETURN END ; IF NOT RdSetLiteral (r.setbase, r.setsize, sbuf) THEN RETURN END ; IF r.kind = 5 THEN k := 0 ; WHILE k < r.setsize DO EmStDiImm (k, ORD (sbuf [k])) ; INC (k) END ELSIF r.kind = 1 THEN k := 0 ; WHILE k < r.setsize DO EmMovAxi (ORD (sbuf [k])) ; EmStoreVar (symtab [r.idx].local, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ; INC (k) END ELSE Err (ENoLib) END ; RETURN END ; IF (r.kind = 5) AND (r.cls = TString) THEN (* A string field of a DI-addressed record element (CALC's `with Sheet[I,J] do Contents := '''). DI is the field's address. A literal's bytes are known: store , truncated to the field's capacity (size-1). A string VARIABLE source uses strstore, with DI pushed as the destination. *) ParseExpr (src) ; IF NOT OK () THEN RETURN END ; n := VarSize (r) - 1 ; (* usable characters *) IF src.kind = 3 THEN IF strLen [src.strx] < n THEN n := strLen [src.strx] END ; EmStDiImm (0, n) ; (* the length byte *) k := 1 ; WHILE k <= n DO EmStDiImm (k, ORD (strPool [strOff [src.strx] + k - 1])) ; INC (k) END ELSIF src.kind = 1 THEN EmPushVarAddr (symtab [src.idx].local, (symtab [src.idx].off + src.boff) MOD 10000H) ; EmPushDi () ; (* destination = the field *) EmMovCxi (n) ; (* strstore's limit *) DropC (EmCall (TU_StrStore)) ; EmAddSp (4) ELSE Err (ENoLib) END ; RETURN END ; IF (r.kind = 1) AND symtab [r.idx].isVar THEN (* `varparam := expr': store through the address the slot holds. DI is parked across the right-hand side because that expression may use DI for a string element of its own. *) IF r.boff # 0 THEN Err (ENoLib) ; RETURN END ; EmStoreVarIndPrep (symtab [r.idx].off) ; ParseExpr (src) ; LoadAtom (src) ; EmPopDi () ; EmStoreInd (VarSize (r)) ; RETURN END ; IF (r.cls = TString) AND (VarSize (r) > 1) THEN (* s := . TPSRC8 asn2 sends a string through the scalar store path, and estcpl's string arm emits `MOV CL,max_len' (max_len = varsize-1) then `CALL strstore', which copies the source - length byte and characters - into the destination and TRUNCATES a source longer than max_len by rewriting the length byte (TPSRC2 strstore's `CMP.B CL,AL / JBE stslenok / MOV.B [SI],AL'). Here the literal is known at compile time, so its bytes become immediate stores instead of a stack push and a block move. The variable that results is the same, truncation included, and the tail past the new length is left as it was, exactly as strstore leaves it. *) ParseExpr (src) ; IF (src.cls # TString) THEN Err (ENoLib) ; RETURN END ; IF src.kind # 3 THEN (* s := . TPSRC8 asnvar pushes the destination address, then the expression (strload) pushes the source, and estcpl emits MOV CL,max_len then CALL strstore, which copies length byte + chars, TRUNCATING to max_len and leaving the destination tail past the new length untouched. Here both addresses are pushed - source first, so it sits at [BP+6] and the destination at [BP+4] - the caller pops both, and the limit is a full MOV CX,imm16 because this runtime reads it in CX outright. *) IF src.kind # 1 THEN Err (ENoLib) ; (* a computed string is not a value *) RETURN END ; EmPushVarAddr (symtab [src.idx].local, (symtab [src.idx].off + src.boff) MOD 10000H) ; EmPushVarAddr (symtab [r.idx].local, (symtab [r.idx].off + r.boff) MOD 10000H) ; EmMovCxi ((VarSize (r) - 1) MOD 10000H) ; DropC (EmCall (TU_StrStore)) ; EmAddSp (4) ; RETURN END ; n := strLen [src.strx] ; IF n > VarSize (r) - 1 THEN n := VarSize (r) - 1 END ; EmMovAxi (n) ; EmStoreVar (symtab [r.idx].local, (symtab [r.idx].off + r.boff) MOD 10000H, 1) ; k := 0 ; WHILE k < n DO EmMovAxi (ORD (strPool [strOff [src.strx] + k])) ; EmStoreVar (symtab [r.idx].local, (symtab [r.idx].off + r.boff + 1 + k) MOD 10000H, 1) ; INC (k) END ; RETURN END ; IF (r.kind = 5) OR (VarSize (r) > 2) THEN IF r.kind = 5 THEN (* An element addressed by DI: a string character (one byte) or an array element (one or two). A wider element - a record - is refused rather than stored as its first two bytes. The destination address is in DI, and the right-hand side is parsed next, so DI has to be saved first - the RHS may hold a subscript of its own, which reuses DI, or call a routine that clobbers it. This is TPSRC8 asnscal2/asnscal3 (758-760, 786-789), which set flgpshdi around the expression for the same reason. *) IF VarSize (r) > 2 THEN Err (ENoLib) ; RETURN END ; EmPushDi () ; ParseExpr (src) ; LoadAtom (src) ; EmPopDi () ; (* DI := the destination again *) EmStoreInd (VarSize (r)) ; (* [DI] := AL or AX *) RETURN END ; (* A value wider than a word with no address to store through: an assignment to a whole string/record/array is not a scalar store. *) Err (ENoLib) ; RETURN END ; ParseExpr (src) ; LoadAtom (src) ; EmStoreVar (symtab [r.idx].local, (symtab [r.idx].off + r.boff) MOD 10000H, VarSize (r)) 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 EmCrtSeq (which : CARDINAL) ; (* The CRT byte sequences, in one parameterised helper. Every one is a fixed BIOS call: CrtClr - INT 10h AH=06 blank the whole window, then AH=02 home the cursor CrtDl - DEC AX ; MOV DL,AL (a 1-based column -> 0-based) CrtDh - DEC AX ; MOV DH,AL (a 1-based row) CrtCaret - INT 10h AH=02, page 0, cursor at DH,DL It takes a parameter on purpose: audit_helpers audits helpers with an EMPTY parameter list byte-for-byte, and these multi-instruction sequences have no single name grammar. Listed as COMP in NON_ONE_LINE, like SetBlob. *) BEGIN IF which = CrtClr THEN Ebyte (0B8H) ; Ebyte (00H) ; Ebyte (06H) ; (* MOV AX,0600h *) Ebyte (8AH) ; Ebyte (3EH) ; Eword (crtAttrOff) ; (* MOV BH,[crtAttr] *) Ebyte (0B9H) ; Ebyte (00H) ; Ebyte (00H) ; (* MOV CX,0000h *) Ebyte (0BAH) ; Ebyte (4FH) ; Ebyte (18H) ; (* MOV DX,184Fh *) Ebyte (0CDH) ; Ebyte (10H) ; (* INT 10h *) Ebyte (0B8H) ; Ebyte (00H) ; Ebyte (02H) ; (* MOV AX,0200h *) Ebyte (0B7H) ; Ebyte (00H) ; (* MOV BH,00h *) Ebyte (0BAH) ; Ebyte (00H) ; Ebyte (00H) ; (* MOV DX,0000h *) Ebyte (0CDH) ; Ebyte (10H) (* INT 10h *) ELSIF which = CrtDl THEN Ebyte (48H) ; (* DEC AX *) Ebyte (88H) ; Ebyte (0C2H) (* MOV DL,AL *) ELSIF which = CrtDh THEN Ebyte (48H) ; (* DEC AX *) Ebyte (88H) ; Ebyte (0C6H) (* MOV DH,AL *) ELSIF which = CrtEol THEN Ebyte (0B4H) ; Ebyte (03H) ; (* MOV AH,03h get cursor *) Ebyte (0B7H) ; Ebyte (00H) ; (* MOV BH,00h *) Ebyte (0CDH) ; Ebyte (10H) ; (* INT 10h -> DH,DL *) Ebyte (89H) ; Ebyte (0D1H) ; (* MOV CX,DX upper-left *) Ebyte (0B2H) ; Ebyte (4FH) ; (* MOV DL,4Fh col 79 *) Ebyte (0B8H) ; Ebyte (00H) ; Ebyte (06H) ; (* MOV AX,0600h blank *) Ebyte (8AH) ; Ebyte (3EH) ; Eword (crtAttrOff) ; (* MOV BH,[crtAttr] *) Ebyte (0CDH) ; Ebyte (10H) (* INT 10h *) ELSIF which = CrtLow THEN (* [crtAttr] := 7: the dim attribute ClrScr/ClrEol use from now on. The runtime's console writer is INT 21h teletype, which has no attribute channel, but the clear operations do - so this is where the setting is observable, not a no-op. *) Ebyte (0C6H) ; Ebyte (06H) ; Eword (crtAttrOff) ; Ebyte (07H) ELSIF which = CrtNorm THEN Ebyte (0C6H) ; Ebyte (06H) ; Eword (crtAttrOff) ; Ebyte (0FH) ELSIF which = CrtKey THEN (* KeyPressed: DOS AH=0Bh asks whether a character is waiting. AL is 0FFh when one is, 0 when not; the boolean representation here is 0/1. AND AX,1, not AND AL,1: the interrupt leaves AH = 0Bh, so the comparison that follows (`CMP AX,0') would read 0B00h and call the false case TRUE. bootcom happened to return AH=0 (it IRETs the handler's whole AX) and hid this; hlt. No argument, no runtime entry. *) Ebyte (0B4H) ; Ebyte (0BH) ; (* MOV AH,0Bh *) Ebyte (0CDH) ; Ebyte (21H) ; (* INT 21h *) Ebyte (25H) ; Ebyte (01H) ; Ebyte (00H) (* AND AX,1 *) ELSIF which = CrtDelay THEN (* Delay(AX) milliseconds: TP3's xdelay, a calibrated busy loop. The count 110 is TP3's default `delaycnt' for 1 ms (TPSRC1). AX = 0 does nothing. *) (* OR AX,AX, not CMP AX,0: check_8086 treats every `CMP AX,0000' in the program region as one of the IF/WHILE/REPEAT tests and demands Jcc+3;EJMP after it. This is neither. *) Ebyte (0BH) ; Ebyte (0C0H) ; (* OR AX,AX *) Ebyte (74H) ; Ebyte (08H) ; (* JZ past the loop *) Ebyte (0B9H) ; Ebyte (6EH) ; Ebyte (00H) ; (* MOV CX,110 (1 ms) *) Ebyte (0E2H) ; Ebyte (0FEH) ; (* LOOP -> itself *) Ebyte (48H) ; (* DEC AX *) Ebyte (75H) ; Ebyte (0F8H) (* JNZ -> MOV CX *) ELSE Ebyte (0B4H) ; Ebyte (02H) ; (* MOV AH,02h *) Ebyte (0B7H) ; Ebyte (00H) ; (* MOV BH,00h *) Ebyte (0CDH) ; Ebyte (10H) (* INT 10h *) END END EmCrtSeq ; 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 arg : ERes ; nArgs, ent, which, acls : CARDINAL ; argBytes : CARDINAL ; (* bytes pushed for this argument: 2, or 4 with a field width *) reading : BOOLEAN ; pushed : BOOLEAN ; skipArg : 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 ; IF which = BI_ClrScr THEN EmCrtSeq (CrtClr) ; RETURN END ; IF which = BI_ClrEol THEN (* clear from the cursor to the end of the line - a real INT 10h call, not a no-op: AH=03 reads the cursor, CX := it, DL := 79, AH=06 blanks that window. *) EmCrtSeq (CrtEol) ; RETURN END ; IF which = BI_GotoXY THEN (* GotoXY (x, y): 1-based; evaluate x first and park it, then y, so the code for y cannot clobber DL. *) IF MatchDelim ('(') THEN ParseExpr (dummy) ; IF OK () THEN LoadAtom (dummy) ; EmPushAx () END ; ExpectDelim (',', ENoSemi) ; ParseExpr (dummy) ; IF OK () THEN LoadAtom (dummy) ; EmCrtSeq (CrtDh) END ; ExpectDelim (')', ENoSemi) ; EmPopAx () ; EmCrtSeq (CrtDl) ; EmCrtSeq (CrtCaret) ELSE Err (ENoSemi) END ; RETURN END ; IF which = BI_LowVideo THEN (* set the attribute the CLEAR operations use to 7; see EmCrtSeq *) EmCrtSeq (CrtLow) ; RETURN END ; IF which = BI_NormVideo THEN EmCrtSeq (CrtNorm) ; RETURN END ; IF which = BI_Delay THEN (* Delay(ms): a real busy loop (EmCrtSeq's CrtDelay), no INT, so it is identical under qemu and Exec86. *) IF MatchDelim ('(') THEN ParseExpr (dummy) ; IF OK () THEN LoadAtom (dummy) ; EmCrtSeq (CrtDelay) END ; ExpectDelim (')', ENoSemi) ELSE Err (ENoSemi) END ; 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 (arg) ; IF NOT OK () THEN (* An argument that did not type-check has no value and arg.idx is not a symbol. The string arm below dereferences symtab[arg.idx] for ANY value whose class is TString - unlike the string assign in Assignment, which can tell a failed concat from a real one by its kind - so a `writeln' of a rejected expression read symtab with whatever idx held before and dereferenced it. That is exactly how `writeln('a' + 'b')' - two CHARs, a type error since v-TP3-STRCAT - segfaulted the compiler instead of reporting the error. ParseSub guards its subscript the same way (see `IF OK () THEN' before symtab[r.idx] there), and the statement loop stops at the next iteration, so leaving the rest of this WRITELN unparsed is harmless. *) RETURN END ; (* One argument at a time: parse it, give it its own push or its own runtime call, and only then read the next one. TPSRC8 pwrloop does exactly this, and it has to - a computed argument exists only in AX, so parsing the argument after it, and the call made for THIS one, are both free to destroy it. Reading the whole list first and emitting afterwards printed the first argument as the last argument's value, and pushed an argument that an earlier inline string's call had already overwritten. *) skipArg := FALSE ; IF (nArgs = 0) AND ((arg.cls = TText) OR (arg.cls = TFile)) THEN (* A leading FILE argument: `Read(Kbd, Ch)'. KBD is the console keyboard and this runtime's read entries already read the console, so the file is dropped and the rest of the argument list is read exactly as without it. A real file is not implemented yet - loud, rather than silently reading the file variable as a data argument. *) IF reading AND (arg.kind = 1) AND symtab [arg.idx].isKbd THEN IF NOT MatchDelim (',') THEN Err (ENoSemi) ; RETURN END ; skipArg := TRUE ELSE Err (ENoLib) ; RETURN END END ; IF NOT skipArg THEN pushed := TRUE ; (* default: value is on the stack -> call + pop *) argBytes := 2 ; IF reading THEN IF (arg.kind # 1) AND (arg.kind # 5) THEN Err (ETypeErr) ; (* READ needs a variable *) RETURN END ; IF arg.kind = 5 THEN (* A DI-addressed element: its TYPE is on the expression (WithLookup/ParseSub set it), because the symbol is the containing array/record. s[i] is TChar; a WITH string field is TString. *) acls := arg.cls ELSE acls := symtab [arg.idx].cls ; (* s[i] is a CHAR variable, so read(s[i]) must read one byte at off+boff, not the whole string at off. arg.cls is TChar (set by ParseSub) while the symbol's own class is still TString, which is exactly how the element is told from the whole string; the address push has to carry boff. For a plain variable arg.boff is 0, so nothing changes. *) IF (acls = TString) AND (arg.cls = TChar) THEN acls := TChar END END ; IF arg.kind = 5 THEN (* A variable index: ParseSub computed the element's address into DI, and nothing has been emitted since, so that is the address READ wants. A constant index folds into boff and takes the LEA path below. *) EmPushDi () ELSIF symtab [arg.idx].isVar THEN (* A VAR parameter: its slot holds the address READ must store through, not the address of the slot. *) IF arg.boff # 0 THEN Err (ENoLib) ; RETURN END ; EmLoadVar (TRUE, symtab [arg.idx].off, 2) ; EmPushAx () ELSE EmPushVarAddr (symtab [arg.idx].local, (symtab [arg.idx].off + arg.boff) MOD 10000H) END ; IF acls = TString THEN (* readln(s)/read(s) of a string variable: TPSRC8 prdstr pushes the address, emits MOV CL,max_len and CALL xrdstr. Here the limit is a full MOV CX,imm16 (this runtime has no byte-register CH/CL setup), and rdstr leaves the terminator pending so the readln wrapper can consume the newline. *) EmMovCxi ((VarSize (arg) - 1) MOD 10000H) ; ent := TU_RdStr ELSIF acls = TReal THEN ent := TU_RdInt (* real reads: not yet *) ELSIF acls = TBool THEN (* TP3 refuses boolean I/O: TPSRC8 prderrtp is error 66, "I/O not allowed here", and the runtime has no xrdbool at all. rdbool stores a WORD, so one byte of an accepted read would land on the variable AFTER b - the exact overflow t37_readbyte pins for a byte. TP3's answer to the whole class is the error; so is ours. *) Err (EIoHere) ; RETURN ELSIF acls = TChar THEN ent := TU_RdChar (* one byte, not a word *) ELSIF acls = TScalar THEN (* Dispatch on the SIZE, as TPSRC8 prdnum does: `CMP varsize,#$01 / JA prdemit' keeps xrdint for anything wider and falls through to `MOV AX,#xrdbyte' for a one-byte variable. A BYTE is still TScalar (it is *written* as an integer, as in TP3), but reading one through rdint stored a word - and the second byte of that word is the byte that FOLLOWS the variable. *) IF VarSize (arg) = 1 THEN ent := TU_RdByte ELSE ent := TU_RdInt END ELSE Err (ETypeErr) ; RETURN END ELSE acls := arg.cls ; IF (acls = TString) AND (arg.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 [arg.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 [arg.strx])) ; n := 0 ; WHILE n < strLen [arg.strx] DO Ebyte (VAL (BYTE, ORD (strPool [strOff [arg.strx] + n]))) ; INC (n) END ; pushed := FALSE (* nothing was pushed for this one *) ELSE IF acls = TString THEN (* A string *variable*. Its value IS its address, so it is passed exactly the way READ passes an address: push it and call the owner of the layout - wrstr - which reads the length byte and prints that many characters. TPSRC8 pwrstr/pwrchk route a string argument to xwrtstr, and xwrtstr reaches its argument through BP just like WrChar does. The only difference from the inline-literal arm above is where the bytes live: a literal's are in the code stream (wrtinl) and a variable's are in the data segment or the frame (wrstr). *) (* off + boff: a string FIELD of a record/array has a non-zero boff, and the address is the field's, not the containing variable's. `writeln (g[2,3].S)' printed the empty first element before this. A DI-addressed field (`with Sheet[I,J] do Write(Contents)') already HAS its address in DI. *) IF arg.kind = 5 THEN EmPushDi () ELSE EmPushVarAddr (symtab [arg.idx].local, (symtab [arg.idx].off + arg.boff) MOD 10000H) END ; ent := TU_WrStr ELSE IF acls = TReal THEN (* A REAL is six bytes, so the writer takes its ADDRESS, not its value: push the address first, then the width, then the decimals. The entry is real_write, with [BP+4]=decimals, [BP+6]=width and [BP+8]=real. TP3's defaults are width 18 and decimals FFFFh (its scientific mode); a width with no second colon keeps that default, which is exactly what TPSRC8 pwrdef/pwrdef3 push. *) IF arg.kind = 5 THEN EmPushDi () ELSE EmPushVarAddr (symtab [arg.idx].local, (symtab [arg.idx].off + arg.boff) MOD 10000H) END ; IF MatchDelim (':') THEN ParseExpr (dummy) ; IF NOT OK () THEN RETURN END ; LoadAtom (dummy) ; EmPushAx () ; IF MatchDelim (':') THEN ParseExpr (dummy) ; IF NOT OK () THEN RETURN END ; LoadAtom (dummy) ; EmPushAx () ELSE EmMovAxi (0FFFFH) ; EmPushAx () END ELSE EmMovAxi (18) ; EmPushAx () ; EmMovAxi (0FFFFH) ; EmPushAx () END ; ent := TU_RealWrite ; argBytes := 6 ELSE LoadAtom (arg) ; EmPushAx () ; IF arg.chr THEN ent := TU_WrChar (* 'a' - one char, not 97 *) 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 ; IF MatchDelim (':') THEN (* Field width: `writeln(I:2)'. TP3 evaluates the width (CALC passes `FW', a variable), so it is parsed and pushed AFTER the value: width at BP+4, value at BP+6. Only an integer has a width entry yet - a CHAR/BOOLEAN/STRING width needs its own writer, and `:decimals' is the REAL form. *) IF (acls # TScalar) OR arg.chr THEN Err (ENoLib) ; RETURN END ; ParseExpr (dummy) ; IF NOT OK () THEN RETURN END ; LoadAtom (dummy) ; EmPushAx () ; IF MatchDelim (':') THEN Err (ENoLib) ; RETURN END ; ent := TU_WrIntW ; argBytes := 4 END END END END END ; IF pushed THEN DropC (EmCall (ent)) ; EmAddSp (argBytes) (* 2, or 4 with a width *) END ; INC (nArgs) END ; IF NOT skipArg THEN IF NOT MatchDelim (',') THEN EXIT END 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 ; 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 ; k, nlbl, nlblJmp, bodyPc, skipJmp : CARDINAL ; nm : ARRAY [0..MaxName] OF CHAR ; strf : BOOLEAN ; dow : BOOLEAN ; savedWith : CARDINAL ; 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) ; (* The body is a STATEMENT SEQUENCE, not one statement: `repeat a; b until c'. This used to call Statmnt once and then demand UNTIL, so any body with a second statement was ENoSemi at the first ';'. t12's two bodies are single statements and never saw it; CALC's `Flash' does (GotoXY; Blink := not Blink; if ...; Write; Delay). Same shape as Compound, stopping at UNTIL instead of END. *) LOOP PeekKw (tok) ; IF tok = TkUntil THEN DropB (MatchKey (tok)) ; EXIT END ; Statmnt () ; IF NOT OK () THEN RETURN END ; IF NOT MatchDelim (';') THEN PeekKw (tok) ; IF tok = TkUntil THEN DropB (MatchKey (tok)) ; EXIT END ; Err (ENoSemi) ; RETURN END 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 labels: `v' | `lo..hi', comma-separated, all selecting the same statement (CALC's `'G', 'I', 'O', 'Q':'). Read the whole list first; the emission then knows whether this is the one-label path or a list. *) nlbl := 0 ; LOOP IF Alpha (CurCh ()) THEN GetWord () ; IF Search (wrd, i2) AND (symtab [i2].tag = KConst) THEN lo := symtab [i2].lval ELSE Err (EUnknown) ; RETURN END ELSE RdConst (lo, clso, strf) END ; IF MatchRange () THEN RdConst (hi, clso, strf) ELSE hi := lo END ; IF nlbl >= 32 THEN Err (ECompOvf) ; RETURN END ; lblLo [nlbl] := lo ; lblHi [nlbl] := hi ; INC (nlbl) ; IF MatchDelim (',') THEN Skip () ELSE EXIT END END ; Skip () ; ExpectDelim (':', ENoSemi) ; IF NOT OK () THEN RETURN END ; EmMovAxSp () ; IF nlbl = 1 THEN (* One label: the original bytes, except that a RANGE is now a real range. It used to compare AX with lo and then with hi, both demanding equality, so `1..5' matched NOTHING unless lo = hi - a silently wrong answer, not an error. *) lo := lblLo [0] ; hi := lblHi [0] ; IF hi = lo THEN EmCmpAxi (W16 (lo)) ; zj := EmJcc (85H, 0) ; (* JNZ -> next arm *) zj2 := 0 ELSE EmCmpAxi (W16 (lo)) ; zj := EmJcc (8CH, 0) ; (* JL -> next arm *) EmCmpAxi (W16 (hi)) ; zj2 := EmJcc (8FH, 0) (* JG -> next arm *) END ; Statmnt () ; IF caseN >= 64 THEN Err (ECompOvf) ; RETURN END ; caseJmp [caseN] := EmJmpNear (0) ; INC (caseN) ; SetPatTgt (zj, pc) ; IF zj2 # 0 THEN SetPatTgt (zj2, pc) END ELSE (* A list. A single label branches INTO the statement; a range first sends AX below lo to the next label, then `<= hi' to the body. The body jumps are patched once the body's address is known, and the no-match EJMP skips the body to the next arm. *) nlblJmp := 0 ; FOR k := 0 TO nlbl - 1 DO IF lblHi [k] = lblLo [k] THEN EmCmpAxi (W16 (lblLo [k])) ; lblJmp [nlblJmp] := EmJcc (84H, 0) ; (* JZ -> body *) INC (nlblJmp) ELSE (* `lo <= AX <= hi', built from the two conditions this compiler declares for a branch (L and G): below lo skips the label, above hi skips it, otherwise an unconditional jump enters the body. JLE would be shorter and is legal 8086, but check_8086's declared condition set is exactly Z/NZ/L/G (the four the parser's comparisons use), and a new condition in CASE would rightly be reported there. *) EmCmpAxi (W16 (lblLo [k])) ; zj := EmJcc (8CH, 0) ; (* JL -> next label *) EmCmpAxi (W16 (lblHi [k])) ; zj2 := EmJcc (8FH, 0) ; (* JG -> next label *) lblJmp [nlblJmp] := EmJmpNear (0) ; (* in range -> body *) INC (nlblJmp) ; SetPatTgt (zj, pc) ; SetPatTgt (zj2, pc) END END ; skipJmp := EmJmpNear (0) ; bodyPc := pc ; FOR k := 0 TO nlblJmp - 1 DO SetPatTgt (lblJmp [k], bodyPc) END ; Statmnt () ; IF caseN >= 64 THEN Err (ECompOvf) ; RETURN END ; caseJmp [caseN] := EmJmpNear (0) ; INC (caseN) ; SetPatTgt (skipJmp, 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 (* WITH base (, base)* DO statement. The record's field range comes from the base symbol: DefVar copies the ELEMENT record's recFldFirst/ recFldLast onto an array variable, which is what makes `Sheet[I,J].Field' and `with Sheet[I,J] do' work. Each base is pushed on the scope stack and popped after the statement. *) savedWith := withN ; LOOP ParseExpr (t) ; IF NOT OK () THEN RETURN END ; IF t.cls # TRecord THEN Err (ETypeErr) ; RETURN END ; IF withN >= 4 THEN Err (ECompOvf) ; RETURN END ; IF symtab [t.idx].fldFirst >= symtab [t.idx].fldLast THEN Err (ETypeErr) ; RETURN END ; IF t.kind = 5 THEN (* the base address is in DI; park it. Allocating two data bytes here is safe: the statement is parsed once, and the store executes wherever the WITH does. *) withSlot [withN] := dc ; dc := dc + 2 ; EmStDiGlob (withSlot [withN]) ; withIsDI [withN] := TRUE ; withBoff [withN] := 0 ELSIF t.kind = 1 THEN withIsDI [withN] := FALSE ; withBoff [withN] := t.boff ELSE Err (ENoLib) ; RETURN END ; withIdx [withN] := t.idx ; withFF [withN] := symtab [t.idx].fldFirst ; withFL [withN] := symtab [t.idx].fldLast ; INC (withN) ; IF MatchDelim (',') THEN (* another base; the last one is innermost *) ELSE EXIT END END ; IF NOT (MatchKey (tok) AND (tok = TkDo)) THEN Err (ENoSemi) ; RETURN END ; Statmnt () ; withN := savedWith ELSE (* identifier statement: assignment or call *) IF WithLookup (wrd, t) THEN IF MatchAssign () THEN Assignment (t) ; RETURN END ; Err (ENoSemi) ; RETURN END ; 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 ; t.sz := symtab [t.idx].size ; (* ParseSub may narrow it further *) 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 ; running, groupFirst, i, an, recStart : CARDINAL ; alo, ahi : ARRAY [0..3] OF LONGINT ; ecls2 : CARDINAL ; BEGIN cls := TNone ; size := 0 ; elem := 0 ; consumed := FALSE ; newArrIdx := 0 ; Skip () ; (* after ':' / '=' : skip blanks *) IF CurCh () = '(' THEN (* An enumeration: `(Constant, Formula, Txt, ...)'. Each enumerator becomes a constant with its ordinal position as its value, and the TYPE is 1 byte (TP3 uses one below 256 values) with bounds 0..n-1, which DefType records so `set of Attributes' can size its base. Enumerators are TScalar, not TEnum: they behave as ordinals; only the TYPE carries the enum identity and its bounds. *) DropCh (GetCh ()) ; lo := 0 ; hi := -1 ; LOOP Skip () ; IF NOT Alpha (CurCh ()) THEN Err (EUnknown) ; RETURN END ; GetWord () ; DupTest (wrd) ; DropC (NewSym (wrd, KConst, TScalar, 1, 1, 0, hi + 1, FALSE)) ; hi := hi + 1 ; IF MatchDelim (',') THEN (* another enumerator *) ELSE EXIT END END ; ExpectDelim (')', ENoSemi) ; enumLo := lo ; enumHi := hi ; cls := TEnum ; size := 1 ; elem := 1 ; RETURN END ; IF Alpha (CurCh ()) THEN DropB (MatchKey (tok)) ; consumed := TRUE ELSE tok := TkNone END ; IF tok = TkArray THEN (* array [range, range, ...] of T. Several ranges are allowed; the LAST varies fastest (row-major), so `Sheet[fx,fy]' strides the first range by the second's count (RESUME-TP3.md §2). The shape is kept in the array table; the symbol carries a pointer to it (SymEntry.arrIdx) so indexing can scale by the element size and subtract each lower bound. *) ExpectDelim ('[', ENoSemi) ; an := 0 ; LOOP RdConst (lo, subcls, strf) ; IF NOT MatchRange () THEN Err (ESimpType) ; RETURN END ; RdConst (hi, subcls, strf) ; IF an < 4 THEN alo [an] := lo ; ahi [an] := hi ; INC (an) END ; IF MatchDelim (',') THEN (* another range *) ELSE EXIT END END ; ExpectDelim (']', ENoSemi) ; IF NOT (MatchKey (tok) AND (tok = TkOf)) THEN Err (ENoSemi) ; RETURN END ; ParseType (cls, s2, e2) ; ecls2 := cls ; cls := TArray ; elem := s2 ; size := s2 ; i := 0 ; WHILE i < an DO size := size * W16 (VAL (LONGINT, W16 (ahi [i])) - VAL (LONGINT, W16 (alo [i])) + 1) ; INC (i) END ; (* register the shape so indexing can scale by element size and subtract each lower bound; the symbol points at this slot *) IF arrTop < MaxArrs THEN arrs [arrTop].n := an ; arrs [arrTop].elem := s2 ; arrs [arrTop].ecls := ecls2 ; i := 0 ; WHILE i < an DO arrs [arrTop].lo [i] := alo [i] ; arrs [arrTop].hi [i] := ahi [i] ; INC (i) END ; newArrIdx := arrTop + 1 ; INC (arrTop) ELSE Err (ECompOvf) END 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 (* set of . TP3's hybrid layout (coeur-tp-ocr 4.7.2): only the whole BYTES covering the base range are stored, so `set of Char' is 32 bytes and `set of 12..17' is 2. `elem' carries the origin - the first element of the first byte, a multiple of 8 - which is all the membership and constructor arithmetic needs. *) PeekKw (tok) ; IF tok = TkOf THEN DropB (MatchKey (tok)) ; RdSetBase (subcls, lo, hi) ; IF OK () THEN cls := TSet ; elem := (VAL (CARDINAL, lo) DIV 8) * 8 ; size := (VAL (CARDINAL, hi) DIV 8) - (VAL (CARDINAL, lo) DIV 8) + 1 END ELSE Err (ENoSemi) END ELSIF tok = TkRecord THEN (* record fieldList end, fields NON-COMPACTED and juxtaposed (RESUME-TP3.md §2). Each name in a `a, b : T' group is a field of its own at the running offset; the field table is where `x.f' looks, keyed per record so field names need not be globally unique. recFldFirst/recFldLast hand the range to DefType, or to the enclosing record's field entry when records nest. *) recStart := fldTop ; recFldFirst := fldTop ; running := 0 ; LOOP PeekKw (tok) ; IF tok = TkEnd THEN DropB (MatchKey (tok)) ; EXIT END ; IF CurCh () = 0C THEN Err (EUnknown) ; EXIT END ; (* the group's names, then ONE `: type' *) groupFirst := fldTop ; LOOP Skip () ; IF NOT Alpha (CurCh ()) THEN Err (EUnknown) ; RETURN END ; GetWord () ; IF fldTop < MaxFields THEN CopyStr (fields [fldTop].name, wrd) ; fields [fldTop].off := 0 ; INC (fldTop) ELSE Err (ECompOvf) END ; IF NOT MatchDelim (',') THEN EXIT END END ; ExpectDelim (':', ENoSemi) ; ParseType (subcls, s2, e2) ; IF NOT OK () THEN RETURN END ; (* every name in the group gets the type and its own slot *) i := groupFirst ; WHILE i < fldTop DO fields [i].cls := subcls ; fields [i].size := s2 ; fields [i].elem := e2 ; fields [i].off := running ; fields [i].lo := enumLo ; fields [i].hi := enumHi ; running := running + s2 ; INC (i) END ; IF NOT MatchDelim (';') THEN Err (ENoSemi) ; RETURN END END ; (* The field TYPES are parsed by ParseType, and its named-type arm copies the TYPE's field range into recFldFirst/recFldLast - for `Integer' that is 0/0. So recFldFirst set at the top of this branch is overwritten by every field type. It happens to be right for the FIRST record in a compile (fldTop is 0 then), and wrong for every later one: t77's second record started at 2 but recorded 0, which made a WITH field lookup scan the previous record's fields. Restore the saved start here, after the last field type has been parsed. *) recFldFirst := recStart ; recFldLast := fldTop ; cls := TRecord ; size := running ; elem := running ELSIF tok = TkText THEN (* A TEXT file variable. We do our own unbuffered INT 21h I/O, so the file variable is just our control block (see FileVarSize) and the element is one byte; TP3 keeps a 128-byte buffer in its own, which is a divergence we do not need. *) cls := TText ; size := FileVarSize ; elem := 1 ELSIF tok = TkFile THEN (* `file' (untyped) or `file of T'. The element type is parsed for its SIZE, which is what a Read/Write moves per record; the variable itself is always the control block. CALC.INC's Exist declares `F : file', so the OF must be optional: requiring it produced ENoSemi at the declaration's semicolon, which was misread as the function declaration being unsupported. TUntyp keeps the untyped file distinguishable, because a Read/Write through it has no element size and must stay refused. *) PeekKw (tok) ; IF tok = TkOf THEN DropB (MatchKey (tok)) ; ParseType (subcls, s2, e2) ; IF OK () THEN cls := TFile ; size := FileVarSize ; elem := s2 END ELSE cls := TUntyp ; size := FileVarSize ; elem := 1 END ELSE IF consumed THEN IF Search (wrd, idx) AND (symtab [idx].tag = KType) THEN cls := symtab [idx].cls ; size := symtab [idx].size ; (* The type's ELEMENT size, not its total size. They are equal for a record, but not for an array (`Letters' is 6 bytes of 3 Integers) or a file. A named array typed constant used to get typElem = 6, wrote six bytes per element and wrapped the little-endian divider to zero: SIGFPE in DefConst. *) elem := symtab [idx].elem ; enumLo := symtab [idx].lo ; enumHi := symtab [idx].hi ; recFldFirst := symtab [idx].fldFirst ; recFldLast := symtab [idx].fldLast ; newArrIdx := symtab [idx].arrIdx ELSE Err (EUnknown) END ELSE (* subrange lo .. hi. TP3 sizes it by its bounds: ONE byte when both are inside 0..255, else two (RESUME-TP3.md §2). `0..20' and `'A'..'G'' are one byte - which is what makes CellRec 80 and not 82, and `Sheet' 147*80. The bounds are kept for `set of T'. *) RdConst (lo, subcls, strf) ; IF NOT MatchRange () THEN Err (ESimpType) ; RETURN END ; RdConst (hi, subcls, strf) ; cls := TScalar ; IF (lo >= 0) AND (hi <= 255) AND (lo <= hi) THEN size := 1 ELSE size := 2 END ; elem := size ; enumLo := lo ; enumHi := hi 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 ; first, i : CARDINAL ; BEGIN LOOP Skip () ; (* after the VAR keyword: skip blanks *) IF NOT Alpha (CurCh ()) THEN Err (EUnknown) ; RETURN END ; (* A group is `name (, name)* : type' - TPSRC7 rdvarlst/rdvloop collects the whole comma-separated list of names FIRST (`CALL ccomma / JZ rdvloop'), then reads one `: type' with ecolon/rdvartp, then vardef2 gives every name in the list that one type. The names are created as placeholders here and filled in once the type is known, which is the same shape as TP3 reserving a symtab slot per name and storing the type pointer into each afterwards. *) first := symTop ; LOOP Skip () ; (* GetWord does not skip blanks, and the cursor sits on the space after the ',' *) IF NOT Alpha (CurCh ()) THEN Err (EUnknown) ; RETURN END ; GetWord () ; SaveWord (nm) ; DupTest (nm) ; DropC (NewSym (nm, KVar, TNone, 0, 0, 0, 0, lexnest # 0)) ; IF NOT MatchDelim (',') THEN EXIT END END ; ExpectDelim (':', ENoSemi) ; ParseType (cls, size, elem) ; IF OK () THEN IF lexnest = 0 THEN IF (size > 2) AND (cls # TString) AND (cls # TRecord) AND (cls # TArray) AND (cls # TFile) AND (cls # TText) AND (cls # TUntyp) THEN (* Still the catch-all for a type whose storage this compiler does not lay out yet (an ARRAY at its point of use, a RECORD, ...). A STRING is the exception now: its layout is length byte + characters, and the rest of the compiler knows it - see Assignment and IoCall. *) 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) ; off := 0 END ; (* TP3's absolute path (vdstore) leaves the offset fixed, so every name in the group aliases the same address. *) i := first ; WHILE i < symTop DO symtab [i].cls := cls ; symtab [i].size := size ; symtab [i].elem := elem ; symtab [i].off := off ; symtab [i].fldFirst := recFldFirst ; symtab [i].fldLast := recFldLast ; symtab [i].arrIdx := newArrIdx ; INC (i) END ELSE i := first ; WHILE i < symTop DO symtab [i].cls := cls ; symtab [i].size := size ; symtab [i].elem := elem ; symtab [i].off := dc ; symtab [i].fldFirst := recFldFirst ; symtab [i].fldLast := recFldLast ; symtab [i].arrIdx := newArrIdx ; dc := dc + size ; INC (i) END END ; varspc := varspc + size * (symTop - first) ELSE IF (size > 2) AND (cls # TString) AND (cls # TRecord) AND (cls # TArray) AND (cls # TFile) AND (cls # TText) AND (cls # TUntyp) THEN Err (ENoLib) ; RETURN END ; (* A local occupies [off, off+size-1] and lives BELOW the saved BP, because BP-relative locals grow down from the top of the frame while a STRING grows UP from its base (length byte, then chars). Top-anchored packing keeps both true at once: locFree is the highest still-free byte (-1 at the top), the new symbol's base is placed so that its LAST byte lands on that byte, and locFree then drops by the whole size. So the first INTEGER (size 2) is at -2 and the second at -4, byte for byte what the old pre-decrement rule produced, while a string[5] local (size 6) is at -6..-1 instead of the old -2..+3 - which straddled the saved BP at [BP] and the return address at [BP+2] and made `readln(s)' into a local store characters over its own return address. Each name in the group gets its own slot. *) i := first ; WHILE i < symTop DO symtab [i].cls := cls ; symtab [i].size := size ; symtab [i].elem := elem ; symtab [i].fldFirst := recFldFirst ; symtab [i].fldLast := recFldLast ; symtab [i].arrIdx := newArrIdx ; symtab [i].off := (locFree - size + 1) MOD 10000H ; locFree := (locFree - size) MOD 10000H ; INC (i) END ; locBytes := locBytes + size * (symTop - first) END END ; IF MatchDelim (',') THEN (* The older `name : type, name : type' spelling: another group follows without a semicolon. TP3's grammar is names-then-one-type with ',' inside a group and ';' between groups (TPSRC7 rdvarlst / rdvloop then ecolon/rdvartp), and both spellings reach the same symbols, so both separators are accepted here. *) ELSIF MatchDelim (';') THEN PeekKw (tok) ; IF tok # TkNone THEN RETURN END ELSE Err (ENoSemi) ; RETURN END END END DefVar ; PROCEDURE DefConst () ; VAR nm : ARRAY [0..MaxName] OF CHAR ; v : LONGINT ; cls, typCls, typSize, typElem, soff, ci : CARDINAL ; isStr : BOOLEAN ; tok : CARDINAL ; typed, setTyped, arrTyped : BOOLEAN ; nb, k, divi, w : 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) ; (* Two spellings: a plain constant `name = value', and a TYPED constant `name : Type = value', which TP3 3.0 added (TPSRC7's constant reader takes the type first and the value second). For a SCALAR type the value still folds to an immediate, so the declared type is simply recorded as the symbol's class - `FXMax : Char = 'G'' is a TChar constant holding 71, and `writeln (FXMax)' prints G rather than 71. A SET typed constant (`Numbers : set of Char = ['0'..'9']') is a value with a layout, so it cannot fold: its bytes are emitted code-resident and the name becomes an addressable value. See the storage decision in CALC-COMPILE.md. An ARRAY or RECORD typed constant is still refused loudly - those layouts come later. *) typed := FALSE ; setTyped := FALSE ; arrTyped := FALSE ; Skip () ; IF CurCh () = ':' THEN DropCh (GetCh ()) ; ParseType (typCls, typSize, typElem) ; IF OK () THEN IF typCls = TSet THEN setTyped := TRUE ELSIF typCls = TArray THEN arrTyped := TRUE ELSIF typSize > 2 THEN Err (ENoLib) ELSE typed := TRUE END END END ; IF OK () AND setTyped THEN ExpectDelim ('=', ENoSemi) ; IF RdSetLiteral (typElem, typSize, constBlob) THEN soff := EmSetBlob (constBlob, typSize) ; DropC (NewSym (nm, KVar, TSet, typSize, typElem, soff, 0, FALSE)) END ELSIF OK () AND arrTyped THEN (* array typed constant: `(v1, v2, ...)' in element order, each value written little-endian in typElem bytes. CALC's is XPOS (seven Integers, 14 bytes). An element that is a STRING (CALC.INC's StandardfunctionNames) is a later increment, and is refused here. *) ExpectDelim ('=', ENoSemi) ; ExpectDelim ('(', ENoSemi) ; nb := 0 ; LOOP RdConst (v, cls, isStr) ; IF isStr OR (nb + typElem > 512) THEN Err (ENoLib) ; EXIT END ; w := VAL (CARDINAL, W16 (v)) ; divi := 1 ; k := 0 ; WHILE k < typElem DO constBlob [nb] := CHR ((w DIV divi) MOD 256) ; divi := divi * 256 ; INC (nb) ; INC (k) END ; IF MatchDelim (',') THEN (* another element *) ELSE EXIT END END ; ExpectDelim (')', ENoSemi) ; IF OK () THEN soff := EmSetBlob (constBlob, typSize) ; ci := NewSym (nm, KVar, TArray, typSize, typElem, soff, 0, FALSE) ; symtab [ci].arrIdx := newArrIdx END ELSIF OK () THEN ExpectDelim ('=', ENoSemi) ; RdConst (v, cls, isStr) ; IF isStr THEN Err (ENoLib) END ; IF OK () THEN IF typed THEN cls := typCls END ; DropC (NewSym (nm, KConst, cls, 0, 0, 0, v, FALSE)) END END ; 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 SlotSize (cls, size : CARDINAL) : CARDINAL ; (* How many bytes a value parameter occupies in the callee's stack frame. TP3's `tstscal' (TPSRC7 1243): a scalar-like parameter is AT LEAST two bytes on the stack even when its type is one byte; anything larger spends its own size. Generalised here so step 2 can put a string's 71 bytes on the stack without changing what a scalar does today. *) BEGIN IF (cls = TScalar) OR (cls = TChar) OR (cls = TBool) OR (cls = TEnum) THEN RETURN 2 END ; RETURN size END SlotSize ; PROCEDURE ParamSlotBytes (e : SymEntry) : CARDINAL ; (* The bytes a parameter occupies in the frame. A VAR parameter's slot is the ADDRESS, always two bytes, whatever its type: `size' stays the type's width so loads and stores know whether they read one byte or two. *) BEGIN IF e.isVar THEN RETURN 2 END ; RETURN SlotSize (e.cls, e.size) END ParamSlotBytes ; 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, groupVar : BOOLEAN ; saveNest, saveLoc, saveRes, saveF : CARDINAL ; saveLB, savePO : CARDINAL ; nestMark : CARDINAL ; (* symTop just inside this procedure *) i, first : 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 := 0FFFFH ; 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) ; groupVar := FALSE ; IF tok = TkVar THEN (* A by-reference parameter: the slot will hold an ADDRESS. `size' still carries the type's own width, because the callee's loads and stores must know whether they move one byte or two. *) DropB (MatchKey (tok)) ; groupVar := TRUE END ; first := symTop ; LOOP Skip () ; (* blanks before the parameter name *) IF NOT Alpha (CurCh ()) THEN Err (EUnknown) ; RETURN END ; GetWord () ; SaveWord (parmNm) ; DupTest (parmNm) ; DropC (NewSym (parmNm, KVar, TNone, 0, 0, 0, 0, TRUE)) ; IF NOT MatchDelim (',') THEN EXIT END END ; ExpectDelim (':', ENoSemi) ; (* formal is 'name : type' *) ParseType (cls, size, elem) ; IF groupVar AND ((size > 2) OR (cls = TString)) THEN (* A VAR parameter of a record, array or string would need the callee to address through a larger object (or a counted string) than the scalar [BX] paths below; refusing is the honest answer, not quietly passing it by value. *) Err (ENoLib) ; RETURN END ; IF (size > 2) AND (cls # TString) THEN (* A string VALUE parameter is a whole-slot copy (n+1 bytes on the stack); any other type wider than a word - a record, an array, a set - is still refused. *) Err (ENoLib) ; RETURN END ; i := first ; WHILE i < symTop DO symtab [i].cls := cls ; symtab [i].size := size ; symtab [i].elem := elem ; symtab [i].off := parmOff ; symtab [i].isVar := groupVar ; IF groupVar THEN parmOff := parmOff + 2 (* the address, whatever the type *) ELSE parmOff := parmOff + SlotSize (cls, size) END ; INC (i) END ; IF MatchDelim (')') THEN EXIT END ; IF MatchDelim (';') THEN (* next group *) ELSIF MatchDelim (',') THEN (* the older `name : type, name : type' spelling *) ELSE Err (ENoSemi) ; EXIT END END ELSE DropCh (GetCh ()) END END ; (* TP3 lays a parameter list out BACKWARDS from BP+4: the LAST declared parameter sits at BP+4 and each earlier one is 2 bytes farther from BP (RESUME-TP3.md 3.11 - "le dernier paramètre déclaré est le plus proche (BP+4)" - and the Code Generation Internals stack frame, "BP+4: last parameter"). This is the other half of pushing the arguments as they are parsed: the first argument is pushed first and so ends up farthest from BP, which has to be the FIRST declared parameter's slot. During the loop the offsets were provisional, in declaration order (parmOff starts at 4 and grows by each parameter's SLOT size), so parameter k sat at 4 + sum of the slots before it. For slot sizes s and frame total T, the parameter's final base is 4 + (T - prefix - s) = 8 + T - off - s, which sends the FIRST declared parameter to the far end and the LAST to BP+4. With every slot 2 - every scalar, which is all this compiler accepts today - that reduces exactly to the old `parmOff + 2 - off`, so no existing frame moves. A slot larger than 2 (a string's 71 bytes) falls out of the same formula, and a VAR parameter is exactly 2 even when its TYPE is one byte: ParamSlotBytes carries that rule. The range is exactly the parameters: the only symbol created while the list is read is the parameter itself (NewSym inside the loop), ParseType creates no symbols, the procedure's own name predates nestMark, and a function's result variable is created after this point. *) i := nestMark ; WHILE i < symTop DO symtab [i].off := 8 + (parmOff - 4) - symtab [i].off - ParamSlotBytes (symtab [i]) ; INC (i) END ; (* Record the parameter list on the procedure symbol: a call site has to know each argument's SLOT size to push and clean up the right number of bytes. Only when this definition actually read a list - a FORWARD's list is kept, and the later `function Expression;' that repeats only the name must not wipe it. *) IF symTop > nestMark THEN symtab [old].parmFirst := nestMark ; symtab [old].parmCount := symTop - nestMark 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 - size + 1) MOD 10000H, 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, tidx : 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 ; tidx := NewSym (nm, KType, cls, size, elem, 0, 0, FALSE) ; IF cls = TEnum THEN (* the enumeration's bounds, set by ParseType, belong to the type - so `set of Attributes' can size its base (0..n-1, one byte) *) symtab [tidx].lo := enumLo ; symtab [tidx].hi := enumHi END ; IF cls = TRecord THEN (* and a record's fields live in the field table; the type records which range is its own *) symtab [tidx].fldFirst := recFldFirst ; symtab [tidx].fldLast := recFldLast END ; IF cls = TArray THEN symtab [tidx].arrIdx := newArrIdx ; (* ...and the ELEMENT's field table, if it is a record. A variable declared `Sheet : Cells' gets its field metadata through the named type; without this, `Sheet[I,J].Field' and `with Sheet[I,J]' found fldFirst = fldLast = 0 and reported "not a record". An INLINE `array ... of Rec' worked because ParseType's element call left the globals set for DefVar; the named form had lost them. *) symtab [tidx].fldFirst := recFldFirst ; symtab [tidx].fldLast := recFldLast END ; DropC (tidx) ; 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 ; i := NewSym ("LENGTH" , KBuiltin, BI_Length , 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; symtab [i].goPos := 0 ; (* inline: the length byte, no entry *) (* The CRT identifiers. ClrScr and GotoXY emit real INT 10h code; the other four are registered so they are recognised, and IoCall refuses them with ENoLib - loud, not inert. *) i := NewSym ("CLRSCR" , KBuiltin, BI_ClrScr , 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("GOTOXY" , KBuiltin, BI_GotoXY , 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("LOWVIDEO", KBuiltin, BI_LowVideo, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("NORMVIDEO", KBuiltin, BI_NormVideo, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("CLREOL" , KBuiltin, BI_ClrEol , 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("DELAY" , KBuiltin, BI_Delay , 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("KEYPRESSED", KBuiltin, BI_KeyPressed, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("UPCASE", KBuiltin, BI_UpCase, 0, 0, 0, 0, FALSE) ; i := NewSym ("SUCC", KBuiltin, BI_Succ, 0, 0, 0, 0, FALSE) ; i := NewSym ("PRED", KBuiltin, BI_Pred, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; (* KBD: the console keyboard as a TEXT file. This runtime's read entries already read the console, so `Read(Kbd, Ch)' drops the file argument and reads a character exactly as `Read(Ch)' does. *) i := NewSym ("KBD", KVar, TText, FileVarSize, 1, 0, 0, FALSE) ; symtab [i].isKbd := TRUE 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 () ; inclActive := FALSE ; inclEnd := 0 ; (* 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 := DataStart ; dc := dataBase ; imgReady := TRUE ; strTop := 0 ; strCnt := 0 ; rdStrX := 0 ; varspc := 0 ; symTop := 0 ; (* Per-compile tables. They used to survive into the next file when the driver compiles several in one process (the compile matrix does exactly that): array indices kept growing, and a record's field range could be read against a stale table. One compile must not depend on the last. *) fldTop := 0 ; arrTop := 0 ; withN := 0 ; nPatch := 0 ; nPend := 0 ; exitCnt := 0 ; brkN := 0 ; caseN := 0 ; lexnest := 0 ; curIsFunc := FALSE ; resultVar := 0 ; locFree := 0FFFFH ; 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 ; (* The text attribute LowVideo/NormVideo set (default 7, written by the prologue). One byte, and its address is baked into the clear sequences. *) crtAttrOff := dc ; DropC (NewSym ("@@ATTR", KVar, TScalar, 1, 1, dc, 0, FALSE)) ; dc := dc + 1 ; (* 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_RealWrite := RT_Entry (30) ; (* fmtreal + padding + output *) 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 *) TU_RdByte := RT_Entry (14) ; (* a BYTE read stores one byte *) TU_SetOp := RT_Entry (31) ; TU_SetCmp := RT_Entry (32) ; TU_SetCopy := RT_Entry (33) ; TU_WrStr := RT_Entry (15) ; (* a string variable is written through the address on the stack *) TU_RdStr := RT_Entry (16) ; (* readln(s)/read(s): TPSRC8 prdstr, TPSRC4 xrdstr *) TU_StrStore := RT_Entry (17) ; (* s := t: TPSRC8 asnvar, TPSRC2 strstore *) TU_CmpStr := RT_Entry (18) ; (* string compare: TPSRC9 vcompare, TPSRC2 cmpstr *) TU_StrCat := RT_Entry (19) ; (* string concatenation: TPSRC2 xconcat *) TU_WrIntW := RT_Entry (20) ; (* width-aware integer: `I:2' *) END Inittur ; PROCEDURE HeadWord (VAR slot : CARDINAL) ; BEGIN slot := pc ; Eword (0) END HeadWord ; PROCEDURE Compile (VAR errNo, errPos : CARDINAL) : BOOLEAN ; VAR tok : CARDINAL ; overProc : CARDINAL ; hasProc : BOOLEAN ; BEGIN Inittur () ; IF OK () THEN (* Resolve every {$I} first: the parser (and DeclaresProc's lookahead) must see one finished buffer. See ExpandIncludes. *) ExpandIncludes () END ; 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 () ; (* [@@ATTR] := 7 - the default text attribute, before any LowVideo or NormVideo runs. The data area is zero-filled, and attribute 0 would make every clear black-on-black. Through EmCrtSeq, not raw Ebyte: Compile is not a one-line emitter, and the helper audit rightly refuses to let a byte-emitting statement hide inside it. *) EmCrtSeq (CrtLow) ; 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 data is NOT part of this image: globals live at DataBase (8000h image) and initmem zeroes them. The .COM is exactly these bytes. *) BEGIN RETURN rtSz + codeSz END ImageBytes ; PROCEDURE DataBase () : CARDINAL ; (* image-absolute offset at which the data area begins (DataStart = 8000H). The data is outside the .COM; initmem zeroes [dataBase, dataBase+dataSz) through the header's hdrDS/hdrHeap words. *) 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.