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. *) FROM CompilerShared IMPORT AposC, ArrRec, BI_Abs, BI_Arctan, BI_Assign, BI_BlockRead, BI_BlockWrite, BI_Chr, BI_Close, BI_ClrEol, BI_ClrScr, BI_Concat, BI_Copy, BI_Cos, BI_Delay, BI_Delete, BI_Dispose, BI_Eof, BI_Erase, BI_Exp, BI_FilePos, BI_FileSize, BI_FillChar, BI_GetDir, BI_GotoXY, BI_Halt, BI_Insert, BI_Int, BI_Intr, BI_IoResult, BI_KeyPressed, BI_Length, BI_Ln, BI_LowVideo, BI_Move, BI_Msdos, BI_New, BI_NormVideo, BI_Ofs, BI_Ord, BI_Pos, BI_Pred, BI_Random, BI_Randomize, BI_Read, BI_ReadLn, BI_Rename, BI_Reset, BI_Rewrite, BI_Round, BI_Seek, BI_Seg, BI_Sin, BI_SizeOf, BI_Sqr, BI_Sqrt, BI_Str, BI_Succ, BI_Trunc, BI_UpCase, BI_Val, BI_Write, BI_WriteLn, CodeMax, CrtCaret, CrtClr, CrtDelay, CrtDh, CrtDl, CrtEol, CrtKey, CrtLow, CrtNorm, DataStart, DirRec, ECompOvf, EConstRange, EFileNF, EInclNest, EIoHere, EMemOvf, ENoLib, ENoSemi, EPointExp, ERes, ESimpType, ETypeErr, EUnknown, EntSize, Err, FileVarSize, FldRec, KBuiltin, KConst, KFunc, KLabel, KProc, KType, KVar, MaxArrs, MaxCode, MaxFields, MaxLine, MaxName, MaxPatch, MaxPend, OK, OpAdd, OpDiv, OpMul, OpShl, OpShr, OpSub, PatchRec, PendRec, TArray, TBool, TChar, TEnum, TFile, TNone, TPtr, TReal, TRecord, TScalar, TSet, TString, TText, TU_BlockRead, TU_BlockWrite, TU_CmpStr, TU_Erase, TU_FileAssign, TU_FileClose, TU_FileEof, TU_FilePos, TU_FileRdln, TU_FileRdtok, TU_FileReadln, TU_FileReset, TU_FileRewrite, TU_FileSize, TU_FillChar, TU_GetDir, TU_Halt, TU_HeapNew, TU_InitMem, TU_IntFmt, TU_IntFmtW, TU_IoResult, TU_IoStore, TU_MemCopy, TU_Move, TU_Msdos, TU_ProgEnd, TU_Random, TU_Randomize, TU_RdBool, TU_RdByte, TU_RdChar, TU_RdInt, TU_RdLn, TU_RdStr, TU_RealAbs, TU_RealAdd, TU_RealArctan, TU_RealCmp, TU_RealCos, TU_RealDiv, TU_RealExp, TU_RealFmt, TU_RealFromInt, TU_RealIntFunc, TU_RealLn, TU_RealMul, TU_RealSin, TU_RealSqrt, TU_RealSub, TU_RealToInt, TU_RealVal, TU_RealWrite, TU_Rename, TU_RunErr, TU_Seek, TU_SetCmp, TU_SetCopy, TU_SetOp, TU_SetSingle, TU_StackChk, TU_StrCat, TU_StrCopy, TU_StrDelete, TU_StrFmtW, TU_StrIndex, TU_StrInsert, TU_StrPos, TU_StrStore, TU_ValInt, TU_ValReal, TU_WrBool, TU_WrBoolW, TU_WrChar, TU_WrCharW, TU_WrInl, TU_WrInt, TU_WrIntW, TU_WrLn, TU_WrReal, TU_WrStr, TU_WrStrW, TUntyp, TkAbsolute, TkAnd, TkArray, TkBegin, TkCase, TkConst, TkDiv, TkDo, TkDownto, TkElse, TkEnd, TkExit, TkExternal, TkFile, TkFor, TkForward, TkFunction, TkGoto, TkIf, TkIn, TkLabel, TkMod, TkNil, TkNone, TkNot, TkOf, TkOr, TkOverlay, TkPacked, TkProcedure, TkProgram, TkRecord, TkRepeat, TkSet, TkString, TkText, TkThen, TkTo, TkType, TkUntil, TkVar, TkWhile, TkWith, abortFac, arrTop, arrs, brkN, brkSave, callScratch, caseJmp, caseN, cbuf, codeSz, constBlob, crtAttrOff, curIsFunc, curProc, curStaticOff, dataBase, dataSz, dc, dirs, entRel, enumHi, enumLo, errNum, exitCnt, exitPatch, fields, fldTop, hdrCS, hdrDS, hdrFlag, hdrHeap, hdrMax, imgReady, lblHi, lblJmp, lblLo, locBytes, locFree, loopTy, nPatch, nPend, newArrIdx, parmOff, patches, pc, pend, prologAt, recFldFirst, recFldLast, resultIsReal, resultPtrOff, resultVar, rtSz, srcPos, tmpA, tmpB, txerrPos, varspc, withBoff, withFF, withFL, withIdx, withIsDI, withN, withSlot ; FROM CompilerEmit IMPORT Ebyte, Eword, PatchWord, AddPatch, SetPatTgt, EmCall, EmJmpNear, JccShort, JccShortInv, EmJcc, ResolvePatches, EmMovAxi, EmMovCxi, EmMovBpSp, EmMovAh0, EmMovAxSp, EmMovCxSp, EmPushAx, EmPopCx, EmPopDx, EmPopSi, EmPopAx, EmPushBx, EmPushCx, EmPushDx, EmPopBx, EmMovAxCx, EmMovChAl, EmMovChImm, EmXchgAxCx, EmXorAxAx, EmAddAxCx, EmSubAxCx, EmMulAxCx, EmIDivAxCx, EmAndAxCx, EmOrAxCx, EmOrAxAx, EmNegAx, EmNotAx, EmXorAl01, EmCmpAxCx, EmCmpAxi, EmSetcc, EmRelSetcc, EmIncAx, EmDecAx, EmBpDisp, EmBxDisp, EmMovBxBp, EmMovDxBp, EmMovDxBx, EmMovDxAx, EmMovAxDx, EmLdBxBx, EmLoadVarBx, EmStoreVarBx, EmLeaDiBx ; FROM CompilerSource IMPORT CurCh, GetCh, PeekAhead, Upper, SetSourcePath, ExpandIncludes, srcLen, inclActive, inclEnd ; FROM CompilerUtil IMPORT Digit, Alpha, AlphaNum, IsHexCh, W16, DropCh, DropB, DropC, BitAnd, BitOr, BitNot, NameEq, CopyStr, NumToName ; FROM CompilerSymbols IMPORT SymEntry, symtab, symTop, lexnest, wrd, NewSym, Search, DupTest, HideLocals, CopyWord, SaveWord ; FROM CompilerLex IMPORT InitKeys, IsBlank, Skip, GetWord, WddTok, DeclaresProc, KwAhead, PeekKw, MatchKey, MatchDelim, MatchAssign, MatchRange, ExpectDelim, HexVal, RdIntConst, StrNew, StrPut, RdConst, strPool, strOff, strLen, strTop, strCnt, rdStrX ; FROM CompilerIO IMPORT IoCall ; FROM CompilerExpr IMPORT AddPend, AllocSetScratch, BinOpEmit, ConstAdd, ConstCmp, ConstMul, ConstSub, EmAsciiZLiteral, EmCallMost, EmCopyRealTo, EmPushRealAddr, EmPushRealSlot, EmPushSetAddr, EmPushStrAddr, EmPushStrOperand, EmPushStrSlot, EmSetBlob, EmStrBlob, EmXchgAxDx, EmitBoundsCheck, FoldSetIn, IntToMbf, IsCharArray, LoadAtom, LoadPair, MaterializeDyn, NewScratchReal, NewScratchRealBlock, NewScratchStr, NewScratchWord, ParmIsVar, ParmSlot, ParseAdd, ParseAtom, ParseCall, ParseCallArgs, ParseCmp, ParseExpr, ParseMul, ParseNeg, ParseSub, ParseVar, RdSetBase, RdSetLiteral, RealBin, RealOperand, RealUnary, SaveLeft, SetBinEmit, SetPairSize, SetRangeBits, StrConcat, StrOperand, VarSize, WithLookup ; (* ---------------------------------------------------------------- *) (* constants *) (* ---------------------------------------------------------------- *) (* ---------------------------------------------------------------- *) (* small char helpers *) (* ---------------------------------------------------------------- *) (* ---------------------------------------------------------------- *) (* errors *) (* ---------------------------------------------------------------- *) (* ---------------------------------------------------------------- *) (* {$I file} include *) (* ---------------------------------------------------------------- *) PROCEDURE SetSource (path : ARRAY OF CHAR) ; (* Public name kept for Shell/Linker; the source module owns the directory string used by {$I file} resolution. *) BEGIN SetSourcePath (path) END SetSource ; 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 EmXorByteGlob (off, v : CARDINAL) ; BEGIN Ebyte (80H) ; Ebyte (36H) ; Eword ((off + LoadBias) MOD 10000H) ; Ebyte (VAL (BYTE, v)) END EmXorByteGlob ; 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 EmMovBxAx () ; BEGIN Ebyte (89H) ; Ebyte (0C3H) END EmMovBxAx ; (* MOV BX,AX *) PROCEDURE EmitFrameBase (level : CARDINAL) ; (* Leave BX pointing at the frame for lexical scope `level', pushing the old BX. The current frame is at `lexnest'; each step follows the hidden static link stored by the enclosing procedure. The caller must POP BX after the access. *) VAR p, k : CARDINAL ; BEGIN EmPushBx () ; EmMovBxBp () ; p := curProc ; k := lexnest ; WHILE k > level DO EmLdBxBx (symtab [p].staticOff) ; p := symtab [p].parent ; DEC (k) END END EmitFrameBase ; PROCEDURE IsOuterLocal (idx : CARDINAL) : BOOLEAN ; BEGIN RETURN symtab [idx].local AND (symtab [idx].level < lexnest) END IsOuterLocal ; PROCEDURE LoadSymVar (idx, off, nbytes : CARDINAL) ; BEGIN IF IsOuterLocal (idx) THEN EmitFrameBase (symtab [idx].level) ; EmLoadVarBx (off, nbytes) ; EmPopBx () ELSE EmLoadVar (symtab [idx].local, off, nbytes) END END LoadSymVar ; PROCEDURE StoreSymVar (idx, off, nbytes : CARDINAL) ; BEGIN IF IsOuterLocal (idx) THEN EmitFrameBase (symtab [idx].level) ; EmStoreVarBx (off, nbytes) ; EmPopBx () ELSE EmStoreVar (symtab [idx].local, off, nbytes) END END StoreSymVar ; PROCEDURE EmPushSymAddr (idx, off : CARDINAL) ; BEGIN IF IsOuterLocal (idx) THEN EmitFrameBase (symtab [idx].level) ; Ebyte (8DH) ; EmBxDisp (off, 0) ; (* LEA AX,[BX+off] *) EmPopBx () ; (* restore BX before pushing AX *) EmPushAx () ELSE EmPushVarAddr (symtab [idx].local, off) END END EmPushSymAddr ; PROCEDURE LeaDiSym (idx, off : CARDINAL) ; BEGIN IF IsOuterLocal (idx) THEN EmitFrameBase (symtab [idx].level) ; EmLeaDiBx (off) ; EmPopBx () ELSE EmLeaDi (symtab [idx].local, off) END END LeaDiSym ; PROCEDURE EmLoadVarIndSym (idx, nbytes : CARDINAL) ; (* AX := the value reached through a VAR parameter's address slot. *) BEGIN LoadSymVar (idx, symtab [idx].off, 2) ; EmMovBxAx () ; IF nbytes = 1 THEN Ebyte (8AH) ; Ebyte (07H) ; EmMovAh0 () ELSE Ebyte (8BH) ; Ebyte (07H) END END EmLoadVarIndSym ; PROCEDURE StoreVarIndPrepSym (idx : CARDINAL) ; (* DI := the address held by a VAR parameter's slot, then PUSH DI. *) BEGIN LoadSymVar (idx, symtab [idx].off, 2) ; EmMovDiAx () ; EmPushDi () END StoreVarIndPrepSym ; PROCEDURE EmitStaticLink (idx : CARDINAL) ; (* Pass the lexical parent frame in DX before a call to a nested procedure. The callee saves it in its hidden static-link local. A top-level procedure has no parent frame and gets nothing. *) VAR level : CARDINAL ; BEGIN level := symtab [idx].level ; IF level = 0 THEN RETURN END ; IF level = lexnest THEN EmMovDxBp () ELSE EmitFrameBase (level) ; EmMovDxBx () ; EmPopBx () END END EmitStaticLink ; 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 EmLdAlSi () ; BEGIN Ebyte (8AH) ; Ebyte (04H) END EmLdAlSi ; (* 8A 04: AL := [SI] *) PROCEDURE EmIncSi () ; BEGIN Ebyte (46H) END EmIncSi ; PROCEDURE EmIncDi () ; BEGIN Ebyte (47H) END EmIncDi ; PROCEDURE EmMovDiAx () ; BEGIN Ebyte (89H) ; Ebyte (0C7H) END EmMovDiAx ; (* 89 C7: DI := AX *) PROCEDURE EmMovAxDi () ; BEGIN Ebyte (89H) ; Ebyte (0F8H) END EmMovAxDi ; (* 89 F8: AX := 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 EmPushSi () ; BEGIN Ebyte (56H) END EmPushSi ; (* PUSH SI *) PROCEDURE EmMovAxDs () ; BEGIN Ebyte (8CH) ; Ebyte (0D8H) END EmMovAxDs ; (* MOV AX,DS *) 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 EmShlAxCl () ; BEGIN Ebyte (0D3H) ; Ebyte (0E0H) END EmShlAxCl ; (* SHL AX,CL *) PROCEDURE EmShrAxCl () ; BEGIN Ebyte (0D3H) ; Ebyte (0E8H) END EmShrAxCl ; (* SHR AX,CL *) 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 EmFileIo (reading : BOOLEAN ; fileLocal : BOOLEAN ; fileOff : CARDINAL ; addrKind : CARDINAL ; addrLocal : BOOLEAN ; addrOff, count : CARDINAL ; stringArg : BOOLEAN) ; (* Typed-file block I/O: read/write `count' bytes at the data argument to the open file in the file variable. ABI to DOS: BX = handle, CX = byte count, DS:DX = buffer, AH = 3Fh read / 40h write. The handle is the first word of the file control block. For a DI-addressed record (`Sheet[I,J]') the address is already in DI; a plain variable's address is formed by LEA. The DOS result is handed to the io_store runtime entry, so IOResult sees it. This is emitted directly rather than through a runtime entry because the runtime has only ~45 bytes of probe headroom left; the code is two words per call site and the compiler's code budget is the loose one. *) BEGIN IF addrKind = 5 THEN (* DI already holds a kind-5 element's address. *) ELSIF addrKind = 4 THEN EmLeaDi (FALSE, addrOff) (* a code-resident blob *) ELSIF addrKind = 1 THEN EmLeaDi (addrLocal, addrOff) ELSE Err (ETypeErr) ; RETURN END ; Ebyte (89H) ; Ebyte (0FAH) ; (* MOV DX,DI *) IF stringArg THEN (* DX points at the characters, CX = the length byte at [DI]. *) Ebyte (42H) ; (* INC DX *) EmLdAlDi () ; EmMovClAl () ; Ebyte (30H) ; Ebyte (0EDH) (* XOR CH,CH *) ELSE EmMovCxi (count) END ; EmLoadVar (fileLocal, fileOff, 2) ; (* AX := the DOS handle *) Ebyte (89H) ; Ebyte (0C3H) ; (* MOV BX,AX *) Ebyte (0B4H) ; (* MOV AH,3Fh/40h *) IF reading THEN Ebyte (3FH) ELSE Ebyte (40H) END ; Ebyte (0CDH) ; Ebyte (21H) ; (* INT 21h *) DropC (EmCall (TU_IoStore)) END EmFileIo ; PROCEDURE EmInlineCh (ch : CARDINAL) : CARDINAL ; (* Emit a one-character string literal behind a JMP and return the image offset of its length byte. Used by text-file Write(File, ' '). *) VAR here : CARDINAL ; BEGIN Ebyte (0EBH) ; Ebyte (2) ; here := pc ; Ebyte (1) ; Ebyte (VAL (BYTE, ch)) ; RETURN here END EmInlineCh ; PROCEDURE EmInlineCrLf () : CARDINAL ; (* The CR LF pair every text-file Writeln emits. *) VAR here : CARDINAL ; BEGIN Ebyte (0EBH) ; Ebyte (3) ; here := pc ; Ebyte (2) ; Ebyte (13) ; Ebyte (10) ; RETURN here END EmInlineCrLf ; 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 *) (* ---------------------------------------------------------------- *) (* ---------------------------------------------------------------- *) (* lexer *) (* ---------------------------------------------------------------- *) (* ---------------------------------------------------------------- *) (* forward declarations *) (* ---------------------------------------------------------------- *) PROCEDURE ParseType (VAR cls, size, elem : CARDINAL) ; FORWARD ; PROCEDURE Statmnt () ; FORWARD ; PROCEDURE SlotSize (cls, size : CARDINAL) : CARDINAL ; FORWARD ; PROCEDURE ParamSlotBytes (e : SymEntry) : CARDINAL ; FORWARD ; PROCEDURE ParseLabelStmt () ; (* numeric or named label definition 'n :' / 'Name:' *) VAR n : CARDINAL ; nm : ARRAY [0..MaxName] OF CHAR ; idx : CARDINAL ; i : CARDINAL ; BEGIN IF Alpha (CurCh ()) THEN GetWord () ; SaveWord (nm) ELSE n := 0 ; WHILE Digit (CurCh ()) DO n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ; DropCh (GetCh ()) END ; NumToName (n, nm) END ; ExpectDelim (':', ENoSemi) ; 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 BoundsOf (r : ERes ; VAR lo, hi : CARDINAL) : BOOLEAN ; (* Find a scalar/subrange bound for an assignment target. Direct symbols use their SymEntry bounds; a record field is found by its byte offset. *) VAR fi : CARDINAL ; BEGIN lo := 0 ; hi := 0 ; IF r.hasBounds THEN lo := W16 (r.blo) ; hi := W16 (r.bhi) ; RETURN TRUE END ; IF r.kind # 1 THEN RETURN FALSE END ; IF symtab [r.idx].fldFirst < symtab [r.idx].fldLast THEN fi := symtab [r.idx].fldFirst ; WHILE fi < symtab [r.idx].fldLast DO IF fields [fi].off = r.boff THEN IF ((fields [fi].cls = TScalar) OR (fields [fi].cls = TEnum) OR (fields [fi].cls = TChar)) AND (fields [fi].lo # fields [fi].hi) THEN lo := W16 (fields [fi].lo) ; hi := W16 (fields [fi].hi) ; RETURN TRUE END ; RETURN FALSE END ; INC (fi) END ; RETURN FALSE END ; IF r.boff = 0 THEN IF ((r.cls = TScalar) OR (r.cls = TEnum) OR (r.cls = TChar)) AND (symtab [r.idx].lo # symtab [r.idx].hi) THEN lo := W16 (symtab [r.idx].lo) ; hi := W16 (symtab [r.idx].hi) ; RETURN TRUE END END ; RETURN FALSE END BoundsOf ; PROCEDURE Assignment (r : ERes) ; (* ':=' already consumed by the caller; store expression into r *) VAR src : ERes ; k, n, savePos, scratch, blo, bhi : 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.kind = 1) AND symtab [r.idx].isPort THEN ParseExpr (src) ; IF NOT OK () THEN RETURN END ; LoadAtom (src) ; EmLoadVar (FALSE, symtab [tmpA].off, 2) ; EmMovDxAx () ; Ebyte (0EEH) ; (* OUT DX,AL *) RETURN END ; IF IsCharArray (r) AND ((r.kind = 1) OR (r.kind = 5)) THEN (* Fixed CHAR arrays are Pascal strings too, but they have no length byte: a literal fills the array and pads the tail with spaces. *) ParseExpr (src) ; IF NOT OK () THEN RETURN END ; IF src.kind = 3 THEN n := VarSize (r) ; k := 0 ; WHILE k < n DO IF k < strLen [src.strx] THEN IF r.kind = 5 THEN EmStDiImm (k, ORD (strPool [strOff [src.strx] + k])) ELSE EmMovAxi (ORD (strPool [strOff [src.strx] + k])) ; StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) END ELSE IF r.kind = 5 THEN EmStDiImm (k, ORD (' ')) ELSE EmMovAxi (ORD (' ')) ; StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) END END ; INC (k) END ; RETURN END ; Err (ETypeErr) ; RETURN END ; IF ((r.kind = 1) OR (r.kind = 5)) AND (VarSize (r) > 2) AND ((r.cls = TRecord) OR (r.cls = TArray)) THEN (* Whole record/array assignment: copy VarSize(r) bytes. This is what BIGREC/DYNREC's `Mother := Self', `Father^ := Mother^' and `Friend[Index] := Mother' need. A DI-addressed destination has to be parked before the source expression can reuse DI. *) IF r.kind = 5 THEN EmPushDi () END ; ParseExpr (src) ; IF NOT OK () THEN RETURN END ; IF (src.kind # 1) AND (src.kind # 5) THEN Err (ETypeErr) ; RETURN END ; IF VarSize (src) # VarSize (r) THEN Err (ETypeErr) ; RETURN END ; IF src.kind = 5 THEN EmPushDi () ELSE EmPushSymAddr (src.idx, (symtab [src.idx].off + src.boff) MOD 10000H) END ; IF r.kind = 5 THEN (* stack now holds dest, source; make it source, dest for the ABI *) EmPopAx () ; EmPopBx () ; EmPushAx () ; EmPushBx () ELSE EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) END ; EmMovCxi (VarSize (r)) ; DropC (EmCall (TU_MemCopy)) ; EmAddSp (4) ; 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. *) IF (r.kind = 1) AND symtab [r.idx].isVar THEN (* VAR REAL parameter: the slot holds the destination address. *) 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) ; LoadSymVar (r.idx, symtab [r.idx].off, 2) ; EmMovDiAx () ; k := 0 ; WHILE k < 6 DO EmStDiImm (k, ORD (rbuf [k])) ; INC (k) END ; RETURN END ; IF (src.cls = TReal) AND ((src.kind = 1) OR (src.kind = 5)) THEN (* Destination pointer first, then the source address; pop SI (source), DI (destination), and copy six bytes. *) LoadSymVar (r.idx, symtab [r.idx].off, 2) ; EmPushAx () ; IF src.kind = 5 THEN EmPushDi () ELSIF symtab [src.idx].isVar THEN LoadSymVar (src.idx, symtab [src.idx].off, 2) ; EmPushAx () ELSE EmPushSymAddr (src.idx, (symtab [src.idx].off + src.boff) MOD 10000H) END ; EmPopSi () ; EmPopDi () ; k := 0 ; WHILE k < 6 DO EmLdAlSi () ; EmStDiAl () ; EmIncSi () ; EmIncDi () ; INC (k) END ; RETURN END ; Err (ENoLib) ; RETURN END ; IF r.kind = 5 THEN EmPushDi () END ; ParseExpr (src) ; IF NOT OK () THEN RETURN END ; IF (src.cls # TReal) AND (src.cls # TString) AND (src.cls # TSet) AND (src.kind # 0) AND ((r.kind = 1) OR (r.kind = 5)) THEN (* INTEGER/CHAR/BOOLEAN -> REAL, e.g. Size := Count in CONVERT. *) scratch := NewScratchReal () ; RealOperand (src, symtab [scratch].off) ; IF r.kind = 5 THEN EmPopDi () END ; k := 0 ; WHILE k < 6 DO LoadSymVar (scratch, (symtab [scratch].off + k) MOD 10000H, 1) ; IF r.kind = 5 THEN EmStDiAlOff (k) ELSE StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) END ; INC (k) END ; RETURN END ; IF (src.kind = 0) AND (src.cls # TString) AND (src.cls # TSet) THEN IntToMbf (src.imm, rbuf) ; IF r.kind = 5 THEN EmPopDi () ; 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])) ; StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ; INC (k) END ELSE Err (ENoLib) END ; RETURN END ; IF (src.kind = 5) AND (src.cls = TReal) AND (r.kind = 5) THEN EmPushDi () ; (* source address *) EmPopSi () ; EmPopDi () ; (* destination address *) k := 0 ; WHILE k < 6 DO EmLdAlSi () ; EmStDiAl () ; EmIncSi () ; EmIncDi () ; INC (k) END ; RETURN END ; IF (src.kind = 5) AND (src.cls = TReal) AND (r.kind = 1) THEN EmPushDi () ; EmPopSi () ; k := 0 ; WHILE k < 6 DO EmLdAlSi () ; StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ; EmIncSi () ; INC (k) 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 ; EmPopDi () ; k := 0 ; WHILE k < 6 DO LoadSymVar (src.idx, (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 LoadSymVar (src.idx, (symtab [src.idx].off + src.boff + k) MOD 10000H, 1) ; StoreSymVar (r.idx, (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 (* A leading constructor normally belongs to the TARGET, because its type (e.g. CALC's one-byte `set of Attributes') is narrower than the default 32-byte literal. But `[A..D] - X' is an expression: parse it through ParseExpr instead of storing it directly. The source cursor is reversible, so try the constructor first. *) savePos := srcPos ; IF NOT RdSetLiteral (r.setbase, r.setsize, sbuf) THEN RETURN END ; Skip () ; IF (CurCh () = '+') OR (CurCh () = '-') OR (CurCh () = '*') THEN srcPos := savePos ELSE 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])) ; StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ; INC (k) END ELSE Err (ENoLib) END ; RETURN END END ; (* `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 src.kind = 9 THEN MaterializeDyn (src, r.setbase, r.setsize) END ; IF r.kind = 1 THEN EmPushSymAddr (r.idx, (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 (r.kind = 5) AND (r.cls = TString) THEN (* A string field of a DI-addressed record element. DI is the field's address; park it because the source expression may reuse DI. *) EmPushDi () ; ParseExpr (src) ; IF NOT OK () THEN RETURN END ; n := VarSize (r) - 1 ; (* usable characters *) IF src.kind = 3 THEN EmPopDi () ; 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 EmPushSymAddr (src.idx, (symtab [src.idx].off + src.boff) MOD 10000H) ; EmPopDi () ; (* destination = the field *) EmPushDi () ; EmMovCxi (n) ; (* strstore's limit *) DropC (EmCall (TU_StrStore)) ; EmAddSp (4) ELSIF src.kind = 5 THEN EmPushDi () ; (* source field address *) EmPopSi () ; EmPopDi () ; (* destination field address *) EmPushSi () ; (* source address *) EmPushDi () ; EmMovCxi (n) ; DropC (EmCall (TU_StrStore)) ; EmAddSp (4) ELSE Err (ENoLib) END ; RETURN END ; IF (r.kind = 1) AND (r.cls = TString) AND symtab [r.idx].isVar THEN (* A VAR string parameter: the slot holds the caller's string address. Copy through the runtime, exactly as a normal string variable does: source address first, destination address second, limit in CX. This covers literals and whole-string expressions alike; the destination address is loaded from the parameter slot rather than formed with LEA, which would point at the slot itself. *) ParseExpr (src) ; IF NOT OK () THEN RETURN END ; IF src.cls # TString THEN Err (ETypeErr) ; RETURN END ; EmPushStrAddr (src) ; LoadSymVar (r.idx, symtab [r.idx].off, 2) ; EmPushAx () ; EmMovCxi ((VarSize (r) - 1) MOD 10000H) ; DropC (EmCall (TU_StrStore)) ; EmAddSp (4) ; 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 ; StoreVarIndPrepSym (r.idx) ; 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 = TChar) OR ((src.cls = TScalar) AND src.chr) THEN (* `s := ch': a one-character string. This is CALC's `EXY := FactorCh' before Val. *) IF src.kind = 0 THEN EmMovAxi (1) ; StoreSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, 1) ; EmMovAxi (W16 (src.imm)) ; StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + 1) MOD 10000H, 1) ELSE LoadAtom (src) ; StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + 1) MOD 10000H, 1) ; EmMovAxi (1) ; StoreSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, 1) END ; RETURN END ; 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 EmPushSymAddr (src.idx, (symtab [src.idx].off + src.boff) MOD 10000H) ELSIF src.kind = 5 THEN (* A string element reached through DI, including a pointer dereference: Buffer^[i]. Its address is already in DI. *) EmPushDi () ELSE Err (ENoLib) ; (* a computed string is not a value *) RETURN END ; EmPushSymAddr (r.idx, (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) ; StoreSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, 1) ; k := 0 ; WHILE k < n DO EmMovAxi (ORD (strPool [strOff [src.strx] + k])) ; StoreSymVar (r.idx, (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) ; IF BoundsOf (r, blo, bhi) THEN EmitBoundsCheck (blo, bhi, 17) END ; 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) ; IF BoundsOf (r, blo, bhi) THEN EmitBoundsCheck (blo, bhi, 17) END ; StoreSymVar (r.idx, (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 + LoadBias) MOD 10000H) ; (* 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 + LoadBias) MOD 10000H) ; (* 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 + LoadBias) MOD 10000H) ; Ebyte (07H) ELSIF which = CrtNorm THEN Ebyte (0C6H) ; Ebyte (06H) ; Eword ((crtAttrOff + LoadBias) MOD 10000H) ; 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 LabelColonAhead () : BOOLEAN ; (* `Label:' is a statement label, but `Name;' is a procedure call. Look past an identifier and blanks without consuming input. *) VAR k : CARDINAL ; ch : CHAR ; BEGIN k := 0 ; ch := PeekAhead (k) ; IF NOT Alpha (ch) THEN RETURN FALSE END ; WHILE AlphaNum (ch) DO INC (k) ; ch := PeekAhead (k) END ; WHILE ch = ' ' DO INC (k) ; ch := PeekAhead (k) END ; IF ch # ':' THEN RETURN FALSE END ; (* `Name := ...' is an assignment, not a label definition. *) INC (k) ; ch := PeekAhead (k) ; WHILE ch = ' ' DO INC (k) ; ch := PeekAhead (k) END ; RETURN ch # '=' END LabelColonAhead ; 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 ()) OR LabelColonAhead () THEN ParseLabelStmt () ; (* consumed the label and ':' *) Statmnt () ; (* the statement follows the label directly *) 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) ; StoreSymVar (idx, 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 () ; LoadSymVar (idx, symtab [idx].off, symtab [idx].size) ; IF symtab [idx].size = 1 THEN (* A CHAR/BYTE control variable loads into AL only. Without zeroing AH, the previous body's leftover AH (wrchar leaves 02h there) makes the 16-bit CMP read 0242h and the loop stops after 'A'. *) EmMovAh0 () END ; 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 *) LoadSymVar (idx, symtab [idx].off, symtab [idx].size) ; IF symtab [idx].size = 1 THEN EmMovAh0 () END ; IF dow THEN EmDecAx () ELSE EmIncAx () END ; StoreSymVar (idx, 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 () ; (* A semicolon between the ELSE statement and the CASE's END is an empty statement, and TP3/CALC writes it after a compound body: `else begin ... end; end`. The non-ELSE path already tolerates the same separator at the top of the arm loop. *) IF MatchDelim (';') THEN Skip () END ; 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 Alpha (CurCh ()) THEN GetWord () ; SaveWord (nm) ELSIF Digit (CurCh ()) THEN RdIntConst (v) ; NumToName (W16 (v), nm) ELSE Err (EUnknown) ; RETURN END ; 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 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 t.fldFirst >= t.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] := t.fldFirst ; withFL [withN] := t.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 (* A field inside WITH may be followed by `.subfield' or `[index]'. *) ParseSub (t) ; IF MatchAssign () THEN Assignment (t) ; RETURN END ; Err (ENoSemi) ; RETURN END ; IF NOT Search (wrd, idx) THEN Err (EUnknown) ; RETURN END ; IF symtab [idx].isPort THEN (* Assignment targets take this direct path instead of ParseVar, so Port[...] must be routed through the same special parser here. *) ParseVar (t) ; IF NOT OK () THEN RETURN END ; IF MatchAssign () THEN Assignment (t) ELSE Err (ENoSemi) END ; 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 *) t.fldFirst := symtab [t.idx].fldFirst ; t.fldLast := symtab [t.idx].fldLast ; t.arrIdx := symtab [t.idx].arrIdx ; t.ptrElem := symtab [t.idx].elem ; t.hasBounds := ((symtab [t.idx].cls = TScalar) OR (symtab [t.idx].cls = TEnum) OR (symtab [t.idx].cls = TChar)) AND (symtab [t.idx].lo # symtab [t.idx].hi) ; t.blo := symtab [t.idx].lo ; t.bhi := symtab [t.idx].hi ; IF t.cls = TSet THEN (* The identifier-statement path does not go through ParseVar, so it must carry the same set metadata: Assignment's set branch uses setsize/setbase to build the constructor. *) t.setoff := symtab [t.idx].off ; t.setbase := symtab [t.idx].elem ; t.setsize := symtab [t.idx].size END ; ParseSub (t) ; IF MatchAssign () THEN Assignment (t) ; RETURN END ; Err (ENoSemi) ; RETURN END ; Err (ENoSemi) END END Statmnt ; (* ---------------------------------------------------------------- *) (* types and declarations (TPSRC7) *) (* ---------------------------------------------------------------- *) PROCEDURE ParseType (VAR cls, size, elem : CARDINAL) ; VAR tok : CARDINAL ; idx : CARDINAL ; lo, hi : LONGINT ; s2, e2 : CARDINAL ; subcls : CARDINAL ; strf : BOOLEAN ; isCharRange : BOOLEAN ; consumed : BOOLEAN ; running, groupFirst, i, an, recStart : CARDINAL ; innerIdx, innerN, leafElem, leafCls, j : CARDINAL ; elemFldFirst, elemFldLast, fieldFldFirst, fieldFldLast, fieldArrIdx : CARDINAL ; elemType : CARDINAL ; elemLo, elemHi : LONGINT ; fieldPtrElem : CARDINAL ; variantBase, armRunning, armMax, savePosVar : CARDINAL ; moreFields : BOOLEAN ; tagName : ARRAY [0..MaxName] OF CHAR ; 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 (* A pointer type: ^Type. The pointer itself is a word; its `elem' field holds the pointee TYPE symbol, not a byte size. The pointee's array/record metadata is copied onto the pointer variable so a dereference can hand it to ParseSub unchanged. *) DropCh (GetCh ()) ; Skip () ; IF NOT Alpha (CurCh ()) THEN Err (ESimpType) ; RETURN END ; GetWord () ; IF Search (wrd, idx) THEN IF symtab [idx].tag # KType THEN Err (ESimpType) ; RETURN END ELSE (* Forward type reference: `Next : ^Person' before the record is declared. Create a placeholder that DefType will fill. *) idx := NewSym (wrd, KType, TNone, 0, 0, 0, 0, FALSE) ; symtab [idx].fwd := TRUE END ; cls := TPtr ; size := 2 ; elem := idx ; (* pointee type symbol *) newArrIdx := symtab [idx].arrIdx ; recFldFirst := symtab [idx].fldFirst ; recFldLast := symtab [idx].fldLast ; enumLo := symtab [idx].lo ; enumHi := symtab [idx].hi ; RETURN END ; 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 Skip () ; IF Alpha (CurCh ()) THEN (* An enum/subrange TYPE as the index: `array[Standardfunction]'. Its bounds are on the type symbol. *) GetWord () ; IF NOT Search (wrd, idx) OR (symtab [idx].tag # KType) OR (symtab [idx].cls # TEnum) THEN Err (ESimpType) ; RETURN END ; lo := symtab [idx].lo ; hi := symtab [idx].hi ELSE RdConst (lo, subcls, strf) ; IF NOT MatchRange () THEN Err (ESimpType) ; RETURN END ; RdConst (hi, subcls, strf) END ; 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 ; innerIdx := newArrIdx ; elemFldFirst := recFldFirst ; elemFldLast := recFldLast ; elemLo := enumLo ; elemHi := enumHi ; elemType := 0 ; IF cls = TPtr THEN elemType := e2 END ; IF (cls = TArray) AND (innerIdx > 0) THEN (* Flatten array-of-array: the outer symbol must index the same number of dimensions as `array[a,b]'. A named element array (`Airplane = array[...] of Dog_Food') carries its shape in the inner ArrRec; keep only the leaf element size and class here. *) leafElem := arrs [innerIdx - 1].elem ; leafCls := arrs [innerIdx - 1].ecls ; elemFldFirst := arrs [innerIdx - 1].fldFirst ; elemFldLast := arrs [innerIdx - 1].fldLast ; elemLo := arrs [innerIdx - 1].elemLo ; elemHi := arrs [innerIdx - 1].elemHi ; elemType := arrs [innerIdx - 1].elemType ; innerN := arrs [innerIdx - 1].n ELSE leafElem := s2 ; leafCls := ecls2 ; innerN := 0 END ; cls := TArray ; elem := leafElem ; 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 flattened shape so indexing can scale by leaf element size and subtract each lower bound; the symbol points at this slot *) IF (an + innerN <= 4) AND (arrTop < MaxArrs) THEN arrs [arrTop].n := an + innerN ; arrs [arrTop].elem := leafElem ; arrs [arrTop].ecls := leafCls ; arrs [arrTop].fldFirst := elemFldFirst ; arrs [arrTop].fldLast := elemFldLast ; arrs [arrTop].elemType := elemType ; arrs [arrTop].elemLo := elemLo ; arrs [arrTop].elemHi := elemHi ; i := 0 ; WHILE i < an DO arrs [arrTop].lo [i] := alo [i] ; arrs [arrTop].hi [i] := ahi [i] ; INC (i) END ; j := 0 ; WHILE j < innerN DO arrs [arrTop].lo [an + j] := arrs [innerIdx - 1].lo [j] ; arrs [arrTop].hi [an + j] := arrs [innerIdx - 1].hi [j] ; INC (j) 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 ; IF tok = TkCase THEN (* Variant part: fields in all arms overlay at the same base. The tag, when named, is an ordinary field before the arms. *) DropB (MatchKey (tok)) ; Skip () ; tagName [0] := CHR (0) ; savePosVar := srcPos ; IF Alpha (CurCh ()) THEN GetWord () ; Skip () ; IF CurCh () = ':' THEN CopyStr (tagName, wrd) ; DropCh (GetCh ()) ; ParseType (subcls, s2, e2) ; IF OK () THEN IF fldTop < MaxFields THEN CopyStr (fields [fldTop].name, tagName) ; fields [fldTop].cls := subcls ; fields [fldTop].size := s2 ; fields [fldTop].elem := e2 ; fields [fldTop].off := running ; fields [fldTop].fldFirst := recFldFirst ; fields [fldTop].fldLast := recFldLast ; fields [fldTop].arrIdx := newArrIdx ; fields [fldTop].ptrElem := 0 ; INC (fldTop) ; running := running + s2 ELSE Err (ECompOvf) END ELSE RETURN END ELSE srcPos := savePosVar ; ParseType (subcls, s2, e2) ; IF NOT OK () THEN RETURN END END ELSE ParseType (subcls, s2, e2) ; IF NOT OK () THEN RETURN END END ; IF NOT (MatchKey (tok) AND (tok = TkOf)) THEN Err (ENoSemi) ; RETURN END ; variantBase := running ; armMax := 0 ; LOOP Skip () ; PeekKw (tok) ; IF tok = TkEnd THEN EXIT END ; RdConst (lo, subcls, strf) ; IF NOT MatchDelim (':') THEN Err (ENoSemi) ; RETURN END ; IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ; armRunning := variantBase ; moreFields := TRUE ; WHILE moreFields AND (CurCh () # ')') DO 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 ; fieldFldFirst := recFldFirst ; fieldFldLast := recFldLast ; fieldArrIdx := newArrIdx ; fieldPtrElem := 0 ; IF subcls = TPtr THEN fieldPtrElem := e2 END ; i := groupFirst ; WHILE i < fldTop DO fields [i].cls := subcls ; fields [i].size := s2 ; fields [i].elem := e2 ; fields [i].off := armRunning ; fields [i].lo := enumLo ; fields [i].hi := enumHi ; fields [i].fldFirst := fieldFldFirst ; fields [i].fldLast := fieldFldLast ; fields [i].arrIdx := fieldArrIdx ; fields [i].ptrElem := fieldPtrElem ; armRunning := armRunning + s2 ; INC (i) END ; IF MatchDelim (';') THEN (* another field group in this arm *) ELSE moreFields := FALSE END END ; ExpectDelim (')', ENoSemi) ; IF armRunning - variantBase > armMax THEN armMax := armRunning - variantBase END ; IF MatchDelim (';') THEN (* another variant arm *) ELSE EXIT END END ; running := variantBase + armMax ; (* the record's own END is read by the outer loop *) ELSE (* 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 ; fieldFldFirst := recFldFirst ; fieldFldLast := recFldLast ; fieldArrIdx := newArrIdx ; fieldPtrElem := 0 ; IF subcls = TPtr THEN fieldPtrElem := e2 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 ; fields [i].fldFirst := fieldFldFirst ; fields [i].fldLast := fieldFldLast ; fields [i].arrIdx := fieldArrIdx ; fields [i].ptrElem := fieldPtrElem ; running := running + s2 ; INC (i) END ; IF NOT MatchDelim (';') THEN Err (ENoSemi) ; RETURN END END ; (* the variant IF *) END ; (* the record field LOOP *) (* 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 = KConst) THEN (* An enum/ordinal subrange written with named constants: `Work = Mon..Fri`. Without this, `Mon' was mistaken for a named TYPE and failed at the first dot. *) lo := symtab [idx].lval ; subcls := symtab [idx].cls ; IF NOT MatchRange () THEN Err (ESimpType) ; RETURN END ; RdConst (hi, subcls, strf) ; IF NOT OK () THEN RETURN END ; cls := TEnum ; IF (lo >= 0) AND (hi <= 255) AND (lo <= hi) THEN size := 1 ELSE size := 2 END ; elem := size ; enumLo := lo ; enumHi := hi ELSIF 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'. *) Skip () ; isCharRange := (ORD (CurCh ()) = AposC) OR (CurCh () = '^') OR (CurCh () = '#') ; RdConst (lo, subcls, strf) ; IF NOT MatchRange () THEN Err (ESimpType) ; RETURN END ; RdConst (hi, subcls, strf) ; IF isCharRange THEN cls := TChar ELSE cls := TScalar END ; 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 ; segAbs : BOOLEAN ; 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) AND (cls # TReal) AND (cls # TSet) 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)) ; Skip () ; segAbs := FALSE ; IF Alpha (CurCh ()) THEN (* Turbo's `Cseg:$80' / `Dseg:$80'. Our globals carry LoadBias in their direct addresses, so subtract it from the requested absolute address. *) GetWord () ; ExpectDelim (':', ENoSemi) ; segAbs := TRUE END ; IF (CurCh () = '$') OR (Digit (CurCh ())) THEN RdIntConst (v) ; IF segAbs THEN off := W16 (v - VAL (LONGINT, LoadBias)) ELSE off := W16 (v) END 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].lo := enumLo ; symtab [i].hi := enumHi ; 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].lo := enumLo ; symtab [i].hi := enumHi ; 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 PeekKw (tok) ; IF tok = TkAbsolute THEN DropB (MatchKey (tok)) ; Skip () ; segAbs := FALSE ; IF Alpha (CurCh ()) THEN GetWord () ; ExpectDelim (':', ENoSemi) ; segAbs := TRUE END ; IF (CurCh () = '$') OR (Digit (CurCh ())) THEN RdIntConst (v) ; IF segAbs THEN off := W16 (v - VAL (LONGINT, LoadBias)) ELSE off := W16 (v) END ELSE Err (EUnknown) ; off := 0 END ; i := first ; WHILE i < symTop DO symtab [i].cls := cls ; symtab [i].size := size ; symtab [i].elem := elem ; symtab [i].off := off ; symtab [i].lo := enumLo ; symtab [i].hi := enumHi ; symtab [i].fldFirst := recFldFirst ; symtab [i].fldLast := recFldLast ; symtab [i].arrIdx := newArrIdx ; symtab [i].local := FALSE ; INC (i) END ELSE IF (size > 2) AND (cls # TString) AND (cls # TRecord) AND (cls # TArray) AND (cls # TFile) AND (cls # TText) AND (cls # TUntyp) AND (cls # TReal) AND (cls # TSet) 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].lo := enumLo ; symtab [i].hi := enumHi ; 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 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, slen, eltCls : 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. Integers are written little-endian in typElem bytes; a STRING element is . CALC uses both XPOS (Integers) and StandardfunctionNames (string[6]). *) ExpectDelim ('=', ENoSemi) ; ExpectDelim ('(', ENoSemi) ; eltCls := 0 ; IF newArrIdx > 0 THEN eltCls := arrs [newArrIdx - 1].ecls END ; nb := 0 ; LOOP RdConst (v, cls, isStr) ; IF nb + typElem > 512 THEN Err (ECompOvf) ; EXIT END ; IF isStr OR ((eltCls = TString) AND (v >= 0) AND (v <= 255)) THEN (* A string element is , padded with NULs to typElem bytes. StandardfunctionNames is array of string[6]. A single-character literal ('I') is a TScalar, not a string, so an array of STRING must still store it as a one-character element. Treating it as an integer divided by 256 once per byte and hit DIV by zero at the fourth. *) IF isStr THEN slen := strLen [rdStrX] ; IF slen > typElem - 1 THEN slen := typElem - 1 END ELSE slen := 1 END ; constBlob [nb] := CHR (slen) ; k := 0 ; WHILE k < typElem - 1 DO IF k < slen THEN IF isStr THEN constBlob [nb + 1 + k] := strPool [strOff [rdStrX] + k] ELSE constBlob [nb + 1 + k] := CHR (v) END ELSE constBlob [nb + 1 + k] := CHR (0) END ; INC (k) END ; nb := nb + typElem ELSIF typElem > 2 THEN (* An array of records/reals has no scalar encoding here. Refuse loudly instead of shifting a 16-bit value through divi until it wraps to zero and aborts the compiler. *) Err (ENoLib) ; EXIT ELSE 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 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..MaxName] OF CHAR ; n : CARDINAL ; BEGIN LOOP Skip () ; IF Alpha (CurCh ()) THEN GetWord () ; SaveWord (nm) ELSIF Digit (CurCh ()) THEN n := 0 ; WHILE Digit (CurCh ()) DO n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ; DropCh (GetCh ()) END ; NumToName (n, nm) ELSE Err (EUnknown) ; RETURN END ; 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 for a scalar, or copy six bytes to the caller's result scratch for a REAL function. *) VAR k : CARDINAL ; BEGIN IF curIsFunc THEN IF OK () THEN IF resultIsReal THEN EmLoadVar (TRUE, resultPtrOff, 2) ; EmMovDiAx () ; k := 0 ; WHILE k < 6 DO EmLoadVar (TRUE, symtab [resultVar].off + k, 1) ; EmStDiAlOff (k) ; INC (k) END ELSE LoadSymVar (resultVar, symtab [resultVar].off, symtab [resultVar].size) END 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, saveRP : CARDINAL ; saveProc, saveStatic, staticOff : CARDINAL ; saveR : BOOLEAN ; realResult : BOOLEAN ; reusedFwd : BOOLEAN ; 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) OR (symtab [idx].tag = KFunc)) 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 ; saveProc := curProc ; saveStatic := curStaticOff ; symtab [old].parent := curProc ; curProc := old ; saveNest := lexnest ; saveLoc := locFree ; saveRes := resultVar ; saveF := VAL (CARDINAL, ORD (curIsFunc)) ; saveLB := locBytes ; savePO := parmOff ; saveRP := resultPtrOff ; saveR := resultIsReal ; 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) AND (cls # TString) AND (cls # TReal) THEN (* A VAR parameter of a record or array would need the callee to address through a larger object than the scalar [BX] paths; refusing is the honest answer. VAR STRING and VAR REAL are the exceptions: both slots are two-byte ADDRESSES, and both value types already have address-based runtime paths. *) Err (ENoLib) ; RETURN END ; IF (size > 2) AND (cls # TString) AND (cls # TReal) 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. A VAR REAL is allowed: its slot is an address, not the six bytes. *) Err (ENoLib) ; RETURN END ; i := first ; WHILE i < symTop DO symtab [i].cls := cls ; symtab [i].size := size ; symtab [i].elem := elem ; symtab [i].lo := enumLo ; symtab [i].hi := enumHi ; 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 ; (* TP3 lets the definition of a forward repeat only the name. CALC writes `function Expression{(...):Real;forward};` -- the parameter list is in a comment, but the body still uses ExpressionCh. The forward's formal symbols are still in the table (HideLocals only changed their level), so make exactly that range visible for this body again. *) reusedFwd := FALSE ; IF (symTop = nestMark) AND symtab [old].fwd AND (symtab [old].parmCount > 0) THEN i := symtab [old].parmFirst ; WHILE i < symtab [old].parmFirst + symtab [old].parmCount DO symtab [i].level := lexnest ; INC (i) END ; reusedFwd := TRUE END ; realResult := FALSE ; IF isFunc THEN IF MatchDelim (':') THEN ParseType (cls, size, elem) ELSIF symtab [old].fwd AND (symtab [old].cls # TNone) THEN (* The definition of a forward repeats only the name; inherit the result type declared by the forward. *) cls := symtab [old].cls ; size := symtab [old].size ; elem := symtab [old].elem ELSE cls := TScalar ; size := 2 ; elem := 2 END ; IF (size > 2) AND (cls # TReal) 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 ; symtab [resultVar].resvar := old ; (* reverse link for self-calls *) locFree := (locFree - size) MOD 10000H ; locBytes := locBytes + size ; resultIsReal := (cls = TReal) ; IF resultIsReal THEN (* Hidden two-byte local holding the caller's result destination. The caller passes it in DI before the CALL. *) resultPtrOff := (locFree - 1) MOD 10000H ; locFree := (locFree - 2) MOD 10000H ; locBytes := locBytes + 2 ELSE resultPtrOff := 0 END 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 ; resultIsReal := saveR ; resultPtrOff := saveRP ; curIsFunc := (saveF # 0) ; locBytes := saveLB ; parmOff := savePO ; curProc := saveProc ; curStaticOff := saveStatic ; RETURN END ; (* A procedure declared inside another one receives its lexical parent's frame in DX. Reserve a hidden local for it before ordinary locals, so nested code can walk the static chain. Top-level procedures have no parent frame and no slot. *) IF symtab [old].level > 0 THEN staticOff := (locFree - 1) MOD 10000H ; locFree := (locFree - 2) MOD 10000H ; locBytes := locBytes + 2 ; symtab [old].staticOff := staticOff ; curStaticOff := staticOff ELSE staticOff := 0 ; curStaticOff := 0 END ; (* Body. Nested procedures are emitted BEFORE the enclosing procedure's prologue: otherwise execution entering the outer procedure falls straight through the nested bodies. The outer entry point is therefore set only after DefPart has emitted them. *) DefPart () ; (* nested declarations; stops at BEGIN *) symtab [old].goPos := pc ; symtab [old].defnd := TRUE ; EmPushBp () ; EmMovBpSp () ; IF symtab [old].level > 0 THEN (* The caller passed the parent frame in DX. *) EmMovAxDx () ; EmStoreVar (TRUE, staticOff, 2) END ; IF resultIsReal THEN (* The caller put the six-byte result destination in DI. Save it before declarations/body can reuse DI. *) EmMovAxDi () ; EmStoreVar (TRUE, resultPtrOff, 2) END ; 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 *) IF reusedFwd THEN (* Hide only the forward's parameter range. HideLocals starts at parmFirst and would also hide every procedure declared between the forward and its definition; t120's `B' disappeared when A was defined that way. *) i := symtab [old].parmFirst ; WHILE i < symtab [old].parmFirst + symtab [old].parmCount DO symtab [i].level := 0FFFFH ; INC (i) END END ; lexnest := saveNest ; locFree := saveLoc ; resultVar := saveRes ; resultIsReal := saveR ; resultPtrOff := saveRP ; curIsFunc := (saveF # 0) ; locBytes := saveLB ; parmOff := savePO ; curProc := saveProc ; curStaticOff := saveStatic 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) ; (* A type name may already exist as a forward placeholder created by `Next : ^Person' before `Person = record'. Reuse that entry; only a real duplicate is an error. *) IF Search (nm, tidx) AND (symtab [tidx].tag = KType) AND (symtab [tidx].cls = TNone) THEN (* fill the placeholder below *) ELSE DupTest (nm) ; tidx := NewSym (nm, KType, TNone, 0, 0, 0, 0, FALSE) END ; ExpectDelim ('=', ENoSemi) ; ParseType (cls, size, elem) ; IF NOT OK () THEN RETURN END ; symtab [tidx].cls := cls ; symtab [tidx].size := size ; symtab [tidx].elem := elem ; symtab [tidx].fwd := FALSE ; IF (cls = TEnum) OR (cls = TChar) OR (cls = TScalar) THEN (* Enumeration and scalar/CHAR subrange bounds, set by ParseType. *) 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 ("ORD", KBuiltin, BI_Ord, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("ROUND", KBuiltin, BI_Round, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("TRUNC", KBuiltin, BI_Trunc, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("MSDOS", KBuiltin, BI_Msdos, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("INTR", KBuiltin, BI_Intr, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("GETDIR", KBuiltin, BI_GetDir, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("SEG", KBuiltin, BI_Seg, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("OFS", KBuiltin, BI_Ofs, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("POS", KBuiltin, BI_Pos, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("CONCAT", KBuiltin, BI_Concat, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("RANDOM", KBuiltin, BI_Random, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("RANDOMIZE", KBuiltin, BI_Randomize, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("FILLCHAR", KBuiltin, BI_FillChar, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("MOVE", KBuiltin, BI_Move, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("SEEK", KBuiltin, BI_Seek, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("FILEPOS", KBuiltin, BI_FilePos, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("FILESIZE", KBuiltin, BI_FileSize, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("ERASE", KBuiltin, BI_Erase, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("RENAME", KBuiltin, BI_Rename, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("BLOCKREAD", KBuiltin, BI_BlockRead, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("BLOCKWRITE", KBuiltin, BI_BlockWrite, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("SIZEOF", KBuiltin, BI_SizeOf, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; 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 ; (* File operations. These are the names CALC actually uses; Eof, not EndOfFile, because CALC declares a variable called EndOfFile. *) i := NewSym ("ASSIGN", KBuiltin, BI_Assign, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("RESET", KBuiltin, BI_Reset, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("REWRITE", KBuiltin, BI_Rewrite, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("CLOSE", KBuiltin, BI_Close, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("IORESULT", KBuiltin, BI_IoResult, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("CHR", KBuiltin, BI_Chr, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("STR", KBuiltin, BI_Str, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("NEW", KBuiltin, BI_New, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("DISPOSE", KBuiltin, BI_Dispose, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("EOF", KBuiltin, BI_Eof, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("VAL", KBuiltin, BI_Val, 0, 0, 0, 0, FALSE) ; DropC (i) ; i := NewSym ("COPY", KBuiltin, BI_Copy, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("ABS", KBuiltin, BI_Abs, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("SQRT", KBuiltin, BI_Sqrt, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("SQR", KBuiltin, BI_Sqr, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("LN", KBuiltin, BI_Ln, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("EXP", KBuiltin, BI_Exp, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("SIN", KBuiltin, BI_Sin, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("COS", KBuiltin, BI_Cos, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("ARCTAN", KBuiltin, BI_Arctan, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("INT", KBuiltin, BI_Int, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("DELETE", KBuiltin, BI_Delete, 0, 0, 0, 0, FALSE) ; symtab [i].defnd := TRUE ; i := NewSym ("INSERT", KBuiltin, BI_Insert, 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 ; (* LST is TP3's printer device. The corpus uses it for listings; define the identifier as a TEXT variable so Write(Lst, ...) type-checks. *) i := NewSym ("LST", KVar, TText, FileVarSize, 1, 0, 0, FALSE) 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 ; curProc := 0 ; curStaticOff := 0 ; curIsFunc := FALSE ; resultVar := 0 ; resultIsReal := FALSE ; resultPtrOff := 0 ; callScratch := 0 ; locFree := 0FFFFH ; locBytes := 0 ; parmOff := 4 ; dirs.rng := FALSE ; 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)) ; (* TP3's absolute byte array `Mem[address]'. The base is chosen so the normal LoadBias addition lands on absolute offset zero. *) arrs [0].n := 1 ; arrs [0].elem := 1 ; arrs [0].ecls := TScalar ; arrs [0].lo [0] := 0 ; arrs [0].hi [0] := 65535 ; arrs [0].fldFirst := 0 ; arrs [0].fldLast := 0 ; arrs [0].elemType := 0 ; i := NewSym ("MEM", KVar, TArray, 65535, 1, W16 (-VAL (LONGINT, LoadBias)), 0, FALSE) ; symtab [i].arrIdx := 1 ; arrTop := 1 ; i := NewSym ("PORT", KVar, TArray, 1, 1, 0, 0, FALSE) ; symtab [i].isPort := TRUE ; 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_WrCharW := RT_Entry (56) ; TU_WrBoolW := RT_Entry (57) ; TU_WrStrW := RT_Entry (58) ; TU_MemCopy := RT_Entry (59) ; TU_RealToInt := RT_Entry (60) ; TU_Msdos := RT_Entry (61) ; TU_GetDir := RT_Entry (64) ; TU_StrPos := RT_Entry (68) ; TU_Randomize := RT_Entry (69) ; TU_Random := RT_Entry (70) ; TU_FillChar := RT_Entry (71) ; TU_Move := RT_Entry (72) ; TU_Seek := RT_Entry (73) ; TU_FilePos := RT_Entry (74) ; TU_FileSize := RT_Entry (75) ; TU_Erase := RT_Entry (76) ; TU_Rename := RT_Entry (77) ; TU_BlockRead := RT_Entry (78) ; TU_BlockWrite := RT_Entry (79) ; TU_RunErr := RT_Entry (80) ; TU_StrIndex := RT_Entry (81) ; TU_WrReal := RT_Entry (6) ; TU_RealWrite := RT_Entry (30) ; (* fmtreal + padding + output *) TU_RealFmt := RT_Entry (28) ; (* fmtreal into a string variable *) TU_RealVal := RT_Entry (29) ; (* ascreal: ASCIIZ -> REAL *) TU_RealCmp := RT_Entry (26) ; (* recmp: AX = -1/0/+1 *) TU_RealAdd := RT_Entry (22) ; TU_RealFromInt := RT_Entry (21) ; TU_RealSub := RT_Entry (23) ; TU_RealMul := RT_Entry (24) ; TU_RealDiv := RT_Entry (25) ; 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_SetSingle := RT_Entry (67) ; TU_FileAssign := RT_Entry (34) ; TU_FileReset := RT_Entry (35) ; TU_FileRewrite := RT_Entry (36) ; TU_FileClose := RT_Entry (37) ; TU_IoResult := RT_Entry (38) ; TU_IoStore := RT_Entry (39) ; TU_HeapNew := RT_Entry (40) ; TU_FileEof := RT_Entry (41) ; TU_FileReadln := RT_Entry (42) ; TU_FileRdtok := RT_Entry (65) ; TU_FileRdln := RT_Entry (66) ; TU_IntFmt := RT_Entry (43) ; TU_IntFmtW := RT_Entry (62) ; TU_StrFmtW := RT_Entry (63) ; TU_ValInt := RT_Entry (44) ; TU_StrCopy := RT_Entry (45) ; TU_ValReal := RT_Entry (46) ; TU_RealAbs := RT_Entry (47) ; TU_RealSqrt := RT_Entry (48) ; TU_RealLn := RT_Entry (49) ; TU_RealExp := RT_Entry (50) ; TU_RealSin := RT_Entry (51) ; TU_RealCos := RT_Entry (52) ; TU_RealArctan := RT_Entry (53) ; TU_RealIntFunc := RT_Entry (27) ; TU_StrDelete := RT_Entry (54) ; TU_StrInsert := RT_Entry (55) ; 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 = 0A000H). 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.