|
|
@@ -63,21 +63,71 @@ FROM Runtime IMPORT RT_Build, RT_Size, RT_Byte, RT_Entry, LoadBias ;
|
|
|
encodings (the entry JMP, every CALL and JMP) must NOT get it: both
|
|
|
operands shift together and the +0100h cancels. *)
|
|
|
|
|
|
-FROM CompilerShared IMPORT MaxCode, CodeMax, EUnknown, EMemOvf, ECompOvf,
|
|
|
- EFileNF, EInclNest, OK, AposC,
|
|
|
- TNone, TArray, TRecord, TSet, TPtr, TFile, TText,
|
|
|
- TUntyp, TString, TReal, TScalar, TBool, TChar, TEnum,
|
|
|
- KLabel, KConst, KType, KVar, KProc, KFunc, KBuiltin,
|
|
|
- TkNone, TkProgram, TkBegin, TkEnd, TkIf, TkThen,
|
|
|
- TkElse, TkWhile, TkDo, TkRepeat, TkUntil, TkFor,
|
|
|
- TkTo, TkDownto, TkCase, TkOf, TkGoto, TkExit,
|
|
|
- TkWith, TkVar, TkConst, TkType, TkLabel, TkProcedure,
|
|
|
- TkFunction, TkNil, TkAnd, TkOr, TkNot, TkDiv,
|
|
|
- TkMod, TkIn, TkFile, TkText, TkRecord, TkArray,
|
|
|
- TkSet, TkPacked, TkForward, TkExternal, TkAbsolute,
|
|
|
- TkOverlay, TkString, dirs,
|
|
|
- PatchRec, cbuf, pc, imgReady, patches, nPatch,
|
|
|
- srcPos, abortFac, errNum, txerrPos, Err ;
|
|
|
+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 ;
|
|
|
|
|
|
@@ -85,7 +135,7 @@ FROM CompilerSource IMPORT CurCh, GetCh, PeekAhead, Upper, SetSourcePath, Expand
|
|
|
FROM CompilerUtil IMPORT Digit, Alpha, AlphaNum, IsHexCh, W16, DropCh,
|
|
|
DropB, DropC, BitAnd, BitOr, BitNot, NameEq,
|
|
|
CopyStr, NumToName ;
|
|
|
-FROM CompilerSymbols IMPORT MaxName, SymEntry, symtab, symTop, lexnest, wrd,
|
|
|
+FROM CompilerSymbols IMPORT SymEntry, symtab, symTop, lexnest, wrd,
|
|
|
NewSym, Search, DupTest, HideLocals,
|
|
|
CopyWord, SaveWord ;
|
|
|
FROM CompilerLex IMPORT InitKeys, IsBlank, Skip, GetWord, WddTok,
|
|
|
@@ -93,310 +143,28 @@ FROM CompilerLex IMPORT InitKeys, IsBlank, Skip, GetWord, WddTok,
|
|
|
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 *)
|
|
|
(* ---------------------------------------------------------------- *)
|
|
|
|
|
|
-CONST
|
|
|
- MaxLine = 128 ;
|
|
|
-
|
|
|
- (* Size of the entry jump at image offset 0: E9 lo hi. The jump's
|
|
|
- displacement is relative to the END of the jump, so every offset in the
|
|
|
- image is EntSize further along than it was before the jump existed. *)
|
|
|
- EntSize = 3 ;
|
|
|
- (* Program layout, image offsets. The original puts the runtime and the
|
|
|
- program's code in CS and the globals in a SEPARATE DS segment, so the
|
|
|
- .COM contains no data and the code is not limited by a data gap. We
|
|
|
- have one flat segment (our boot loader), so the same property is
|
|
|
- obtained by putting the globals at a fixed high image offset: the .COM
|
|
|
- is code-only, hdrDS points at DataStart, and initmem zeroes it. The
|
|
|
- code must end below CodeMax. DataStart is now 0xA000h so the large CALC
|
|
|
- image fits; the current boot harness still puts its input descriptor at
|
|
|
- memory 7000h, so a .COM above that is compile-only until the loader is
|
|
|
- moved. *)
|
|
|
- DataStart = 0A000H ; (* image offset of the first global (memory 0A100h) *)
|
|
|
-
|
|
|
- MaxPend = 400 ;
|
|
|
- MaxFields = 2000 ; (* record fields, in a table of their own: a
|
|
|
- field is scoped to its record, not global *)
|
|
|
- MaxArrs = 1000 ; (* array SHAPES, likewise: a symbol points at
|
|
|
- one, and 2-D indexing needs both ranges *)
|
|
|
- FileVarSize = 132 ; (* a file variable is our control block: the DOS
|
|
|
- handle (word), a mode word (0 closed, 1 read,
|
|
|
- 2 write), then a 128-byte NUL-terminated
|
|
|
- filename. TP3 keeps its own name buffer and
|
|
|
- a 128-byte data buffer here; we keep the name
|
|
|
- and do unbuffered INT 21h I/O, with the data
|
|
|
- buffer supplied by the caller. *)
|
|
|
-
|
|
|
- (* which standard procedure a KBuiltin symbol denotes *)
|
|
|
- BI_Write = 0 ; BI_WriteLn = 1 ; BI_Read = 2 ;
|
|
|
- BI_ReadLn = 3 ; BI_Halt = 4 ; BI_Length = 5 ;
|
|
|
- (* CRT identifiers. There is no unit system, so these are builtins. They
|
|
|
- are statements (except Length), dispatched in IoCall; each one that is
|
|
|
- not implemented yet is a loud ENoLib, never a silent no-op. *)
|
|
|
- BI_ClrScr = 6 ; BI_GotoXY = 7 ; BI_LowVideo = 8 ;
|
|
|
- BI_NormVideo = 9 ; BI_ClrEol = 10 ; BI_Delay = 11 ;
|
|
|
- BI_KeyPressed = 12 ; BI_UpCase = 13 ; BI_Succ = 14 ; BI_Pred = 15 ;
|
|
|
- (* File operations. TP3 has these as standard procedures/functions; our
|
|
|
- control block is Compiler.FileVarSize, so Assign stores the name for
|
|
|
- the later Reset/Rewrite. IOResult is an expression; EndOfFile is the
|
|
|
- next file increment. *)
|
|
|
- BI_Assign = 16 ; BI_Reset = 17 ; BI_Rewrite = 18 ;
|
|
|
- BI_Close = 19 ; BI_IoResult = 20 ; BI_Chr = 21 ; BI_Str = 22 ;
|
|
|
- BI_New = 23 ; BI_Dispose = 24 ; BI_Eof = 25 ; BI_Val = 26 ;
|
|
|
- BI_Copy = 27 ; BI_Abs = 28 ; BI_Sqrt = 29 ; BI_Sqr = 30 ;
|
|
|
- BI_Ln = 31 ; BI_Exp = 32 ; BI_Sin = 33 ; BI_Cos = 34 ; BI_Arctan = 35 ;
|
|
|
- BI_Int = 36 ; BI_Delete = 37 ; BI_Insert = 38 ; BI_Ord = 39 ;
|
|
|
- BI_Round = 40 ; BI_Trunc = 41 ; BI_Msdos = 42 ; BI_Intr = 43 ;
|
|
|
- BI_GetDir = 44 ; BI_Seg = 45 ; BI_Ofs = 46 ; BI_Pos = 47 ; BI_Concat = 48 ;
|
|
|
- BI_Random = 49 ; BI_Randomize = 50 ; BI_FillChar = 51 ; BI_Move = 52 ;
|
|
|
- BI_Seek = 53 ; BI_FilePos = 54 ; BI_FileSize = 55 ;
|
|
|
- BI_Erase = 56 ; BI_Rename = 57 ; BI_BlockRead = 58 ; BI_BlockWrite = 59 ;
|
|
|
- BI_SizeOf = 60 ;
|
|
|
- (* the sub-codes EmCrtSeq takes *)
|
|
|
- CrtClr = 0 ; CrtDl = 1 ; CrtDh = 2 ; CrtCaret = 3 ; CrtEol = 4 ;
|
|
|
- CrtLow = 5 ; CrtNorm = 6 ; CrtDelay = 7 ; CrtKey = 8 ;
|
|
|
-
|
|
|
- (* Codes for the SYMBOL operators, as BinOpEmit numbers them. The word
|
|
|
- operators carry their own Tk* token and need no code here.
|
|
|
- These are named, not bare numbers, because every precedence level's
|
|
|
- parser picks its own code out of the same set and BinOpEmit cannot see
|
|
|
- which level called it. ParseAdd chose 1 for '+' and ParseMul chose 1
|
|
|
- for '*', so every multiplication dispatched to EmAddAxCx and a * b
|
|
|
- compiled to a + b. Only the constant-folding path was right, which is
|
|
|
- why n * n with n a CONST was correct and a * b with a a variable was
|
|
|
- not. *)
|
|
|
- OpAdd = 1 ; OpSub = 2 ; OpMul = 3 ; OpDiv = 4 ;
|
|
|
- OpShl = 5 ; OpShr = 6 ;
|
|
|
-
|
|
|
- (* TP3 error numbers *)
|
|
|
- ENoSemi = 1 ; EPointExp = 10 ; ESimpType = 30 ;
|
|
|
- EConstRange = 45 ; ENoLib = 102 ; ETypeErr = 56 ;
|
|
|
- EIoHere = 66 ; (* I/O not allowed here - TPSRC8 prderrtp *)
|
|
|
-
|
|
|
-
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-(* types *)
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-
|
|
|
-TYPE
|
|
|
- PendRec =
|
|
|
- RECORD
|
|
|
- kind : CARDINAL ; (* 0 goto, 1 call *)
|
|
|
- who : CARDINAL ;
|
|
|
- place : CARDINAL ; (* patch slot index *)
|
|
|
- END ;
|
|
|
-
|
|
|
- ERes =
|
|
|
- RECORD
|
|
|
- cls : CARDINAL ;
|
|
|
- kind : CARDINAL ; (* 0 const, 1 var, 2 value in AX,
|
|
|
- 3 string literal (cls = TString),
|
|
|
- 4 value on the stack (SaveLeft),
|
|
|
- 5 string element, address in DI,
|
|
|
- 7 set value (cls = TSet) *)
|
|
|
- imm : LONGINT ;
|
|
|
- idx : CARDINAL ;
|
|
|
- boff : CARDINAL ; (* constant fold-in for subscripts *)
|
|
|
- chr : BOOLEAN ; (* single-quoted literal, e.g. 'a' *)
|
|
|
- strx : CARDINAL ; (* string literal: index into strPool *)
|
|
|
- setoff : CARDINAL ; (* SET value: image offset of the bytes *)
|
|
|
- setbase : CARDINAL ; (* ... the first byte's first element,
|
|
|
- a multiple of 8 (TP3's hybrid origin) *)
|
|
|
- setsize : CARDINAL ; (* ... and how many bytes there are *)
|
|
|
- sz : CARDINAL ; (* width of a kind-1 value: an element or
|
|
|
- field's size, not its variable's *)
|
|
|
- fldFirst, fldLast : CARDINAL ; (* current record metadata *)
|
|
|
- arrIdx : CARDINAL ; (* current array shape, if any *)
|
|
|
- ptrElem : CARDINAL ; (* pointee type, for pointer arrays *)
|
|
|
- dynElem : CARDINAL ; (* element symbol for a dynamic set literal *)
|
|
|
- blo, bhi : LONGINT ; (* current scalar/subrange bounds *)
|
|
|
- hasBounds : BOOLEAN ;
|
|
|
- END ;
|
|
|
-
|
|
|
- FldRec =
|
|
|
- RECORD
|
|
|
- name : ARRAY [0..MaxName] OF CHAR ;
|
|
|
- cls : CARDINAL ;
|
|
|
- size : CARDINAL ;
|
|
|
- elem : CARDINAL ;
|
|
|
- off : CARDINAL ; (* byte offset within the record *)
|
|
|
- lo, hi : LONGINT ; (* bounds, for a subrange/enum field *)
|
|
|
- fldFirst, fldLast : CARDINAL ; (* nested record metadata *)
|
|
|
- arrIdx : CARDINAL ;
|
|
|
- ptrElem : CARDINAL ;
|
|
|
- END ;
|
|
|
-
|
|
|
- ArrRec =
|
|
|
- RECORD
|
|
|
- n : CARDINAL ; (* number of ranges (1 for array[1..5]) *)
|
|
|
- lo, hi : ARRAY [0..3] OF LONGINT ;
|
|
|
- elem : CARDINAL ; (* element size in bytes *)
|
|
|
- ecls : CARDINAL ; (* element CLASS, for a subscripted value *)
|
|
|
- fldFirst, fldLast : CARDINAL ; (* leaf record metadata *)
|
|
|
- elemType : CARDINAL ;
|
|
|
- elemLo, elemHi : LONGINT ; (* leaf element subrange bounds *)
|
|
|
- END ;
|
|
|
-
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-(* state *)
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-
|
|
|
-VAR
|
|
|
- enumLo, enumHi : LONGINT ; (* bounds of the enumeration ParseType just read,
|
|
|
- handed to DefType which owns the type NAME *)
|
|
|
- fields : ARRAY [0..MaxFields - 1] OF FldRec ;
|
|
|
- fldTop : CARDINAL ; (* next free field-table slot *)
|
|
|
- recFldFirst, recFldLast : CARDINAL ; (* field range ParseType just built *)
|
|
|
- arrs : ARRAY [0..MaxArrs - 1] OF ArrRec ;
|
|
|
- arrTop : CARDINAL ; (* next free array-shape slot *)
|
|
|
- newArrIdx : CARDINAL ; (* ArrRec index+1 for the type just parsed *)
|
|
|
- constBlob : ARRAY [0..511] OF CHAR ; (* bytes of a set/array typed constant
|
|
|
- while it is being built *)
|
|
|
-
|
|
|
- pend : ARRAY [0..MaxPend - 1] OF PendRec ;
|
|
|
- nPend : CARDINAL ;
|
|
|
-
|
|
|
- exitPatch : ARRAY [0..63] OF CARDINAL ;
|
|
|
- exitCnt : CARDINAL ;
|
|
|
- brkSave : ARRAY [0..15] OF CARDINAL ;
|
|
|
- loopTy : ARRAY [0..15] OF CARDINAL ; (* 1 while/repeat, 2 for *)
|
|
|
- brkN : CARDINAL ;
|
|
|
-
|
|
|
- caseJmp : ARRAY [0..63] OF CARDINAL ;
|
|
|
- caseN : CARDINAL ;
|
|
|
-
|
|
|
- (* the active WITH scopes, innermost last. A DI-based base (an array
|
|
|
- element addressed at run time) is parked in a two-byte data slot: the
|
|
|
- body may clobber DI, so each field access reloads it. *)
|
|
|
- withN : CARDINAL ;
|
|
|
- withIsDI : ARRAY [0..3] OF BOOLEAN ;
|
|
|
- withIdx : ARRAY [0..3] OF CARDINAL ;
|
|
|
- withBoff : ARRAY [0..3] OF CARDINAL ;
|
|
|
- withSlot : ARRAY [0..3] OF CARDINAL ;
|
|
|
- withFF : ARRAY [0..3] OF CARDINAL ;
|
|
|
- withFL : ARRAY [0..3] OF CARDINAL ;
|
|
|
- lblLo, lblHi : ARRAY [0..31] OF LONGINT ; (* one arm's label list *)
|
|
|
- lblJmp : ARRAY [0..63] OF CARDINAL ; (* its body jumps: 1 or 2 per label *)
|
|
|
-
|
|
|
- dc : CARDINAL ;
|
|
|
- varspc : CARDINAL ;
|
|
|
- codeSz, dataSz : CARDINAL ;
|
|
|
-
|
|
|
- (* Image layout, all image-absolute. rtSz is where the runtime ends and
|
|
|
- the program header begins; dataBase is the fixed high global area
|
|
|
- (DataStart = 0A000H image, 0A100H memory), which is NOT part of the .COM
|
|
|
- image: initmem zeroes it at startup, as the original's separate DS
|
|
|
- segment is zeroed. codeSz and dataSz are PROGRAM sizes - the runtime is
|
|
|
- excluded. *)
|
|
|
- rtSz, dataBase : CARDINAL ;
|
|
|
-
|
|
|
- (* Image offset of the entry jump's rel16 operand, patched at the end of
|
|
|
- Compile. The jump is at image offset 0, so its displacement is simply
|
|
|
- the program code's end - 3. *)
|
|
|
- entRel, prologAt : CARDINAL ;
|
|
|
-
|
|
|
- (* Runtime entry offsets as IMAGE-ABSOLUTE addresses, which is what
|
|
|
- EmCall and EmJmp want. They are derived from Runtime.RT_Entry in
|
|
|
- Inittur (after RT_Build, since RT_Entry only knows where the code
|
|
|
- landed once the blob is assembled) rather than written down, so a moved
|
|
|
- entry cannot leave the compiler calling the old address. Not a CONST
|
|
|
- block because RT_Entry is a function.
|
|
|
-
|
|
|
- Standard-procedure entries: TP3 does NOT pass a descriptor -
|
|
|
- TPSRC8 pwriteln/pwrloop inspects each argument's class in CL and emits
|
|
|
- a *different* call per type, so the type is fixed at compile time and
|
|
|
- the runtime needs only the value. Mirrored here. *)
|
|
|
- TU_InitMem : CARDINAL ;
|
|
|
- TU_ProgEnd : CARDINAL ;
|
|
|
- TU_StackChk : CARDINAL ;
|
|
|
- TU_WrInt : CARDINAL ; TU_WrIntW : CARDINAL ;
|
|
|
- TU_WrChar : CARDINAL ; TU_WrBool : CARDINAL ;
|
|
|
- TU_WrCharW : CARDINAL ; TU_WrBoolW : CARDINAL ; TU_WrStrW : CARDINAL ;
|
|
|
- TU_MemCopy : CARDINAL ;
|
|
|
- TU_RealToInt : CARDINAL ;
|
|
|
- TU_Msdos : CARDINAL ;
|
|
|
- TU_GetDir : CARDINAL ;
|
|
|
- TU_StrPos : CARDINAL ;
|
|
|
- TU_Randomize : CARDINAL ; TU_Random : CARDINAL ;
|
|
|
- TU_FillChar : CARDINAL ; TU_Move : CARDINAL ;
|
|
|
- TU_Seek : CARDINAL ; TU_FilePos : CARDINAL ; TU_FileSize : CARDINAL ;
|
|
|
- TU_Erase : CARDINAL ; TU_Rename : CARDINAL ;
|
|
|
- TU_BlockRead : CARDINAL ; TU_BlockWrite : CARDINAL ;
|
|
|
- TU_RunErr : CARDINAL ;
|
|
|
- TU_StrIndex : CARDINAL ;
|
|
|
- TU_WrReal : CARDINAL ; TU_RealWrite : CARDINAL ; TU_RealFmt : CARDINAL ;
|
|
|
- TU_RealVal : CARDINAL ; TU_RealCmp : CARDINAL ;
|
|
|
- TU_RealAdd : CARDINAL ; TU_RealSub : CARDINAL ;
|
|
|
- TU_RealMul : CARDINAL ; TU_RealDiv : CARDINAL ;
|
|
|
- TU_RealFromInt : CARDINAL ;
|
|
|
- TU_WrLn : CARDINAL ;
|
|
|
- TU_RdInt : CARDINAL ; TU_RdChar : CARDINAL ; TU_RdBool : CARDINAL ;
|
|
|
- TU_RdLn : CARDINAL ; TU_Halt : CARDINAL ;
|
|
|
- TU_RdByte : CARDINAL ; (* one-byte variable reads; see IoCall *)
|
|
|
- TU_WrInl : CARDINAL ; (* inline string literal; NO stack argument *)
|
|
|
- TU_WrStr : CARDINAL ; (* string variable; address is the stack argument *)
|
|
|
- TU_RdStr : CARDINAL ; (* readln(s)/read(s); address on the stack, limit
|
|
|
- in CX *)
|
|
|
- TU_StrStore : CARDINAL ; (* s := t; dest and source addresses on the stack,
|
|
|
- limit in CX *)
|
|
|
- TU_SetOp : CARDINAL ; (* runtime set operations, entries 31..33 *)
|
|
|
- TU_SetCmp : CARDINAL ;
|
|
|
- TU_SetCopy : CARDINAL ;
|
|
|
- TU_SetSingle : CARDINAL ;
|
|
|
- TU_FileAssign : CARDINAL ; (* file control block operations, entries 34..38 *)
|
|
|
- TU_FileReset : CARDINAL ;
|
|
|
- TU_FileRewrite : CARDINAL ;
|
|
|
- TU_FileClose : CARDINAL ;
|
|
|
- TU_IoResult : CARDINAL ;
|
|
|
- TU_IoStore : CARDINAL ; (* save AX as the last I/O status *)
|
|
|
- TU_HeapNew : CARDINAL ; (* bump allocation for New *)
|
|
|
- TU_FileEof : CARDINAL ; (* text-file end of file *)
|
|
|
- TU_FileReadln : CARDINAL ; (* text-file line read *)
|
|
|
- TU_FileRdtok : CARDINAL ; (* text-file token read *)
|
|
|
- TU_FileRdln : CARDINAL ; (* discard the rest of a text-file line *)
|
|
|
- TU_IntFmt : CARDINAL ; (* integer -> counted string *)
|
|
|
- TU_IntFmtW : CARDINAL ; (* integer -> counted string, width-padded *)
|
|
|
- TU_StrFmtW : CARDINAL ; (* string -> fixed-width counted string *)
|
|
|
- TU_ValInt : CARDINAL ; (* counted string -> integer *)
|
|
|
- TU_StrCopy : CARDINAL ; (* Copy(S,start,len) *)
|
|
|
- TU_ValReal : CARDINAL ; (* counted string -> REAL *)
|
|
|
- TU_RealAbs : CARDINAL ; TU_RealSqrt : CARDINAL ;
|
|
|
- TU_RealLn : CARDINAL ; TU_RealExp : CARDINAL ;
|
|
|
- TU_RealSin : CARDINAL ; TU_RealCos : CARDINAL ; TU_RealArctan : CARDINAL ;
|
|
|
- TU_RealIntFunc : CARDINAL ; TU_StrDelete : CARDINAL ;
|
|
|
- TU_StrInsert : CARDINAL ;
|
|
|
- TU_CmpStr : CARDINAL ; (* string comparison; two addresses on the stack,
|
|
|
- signed -1/0/+1 in AX *)
|
|
|
- TU_StrCat : CARDINAL ; (* string concatenation; dest and source addresses
|
|
|
- on the stack, limit in CX; exit code 16 if the
|
|
|
- result would be too long *)
|
|
|
-
|
|
|
- curProc : CARDINAL ; (* symbol of the procedure body being compiled *)
|
|
|
- curStaticOff : CARDINAL ; (* its hidden static-link slot, 0 if none *)
|
|
|
- curIsFunc : BOOLEAN ;
|
|
|
- resultVar : CARDINAL ;
|
|
|
- resultIsReal : BOOLEAN ; (* the CURRENT function returns TReal *)
|
|
|
- resultPtrOff : CARDINAL ; (* hidden local: caller's 6-byte result dest *)
|
|
|
- callScratch : CARDINAL ; (* per-site real-result scratch symbol *)
|
|
|
-
|
|
|
- locFree : CARDINAL ; (* next local slot (BP-relative, 8-bit) *)
|
|
|
- locBytes : CARDINAL ; (* frame size for SUB SP *)
|
|
|
- parmOff : CARDINAL ; (* provisional parameter slot, in declaration
|
|
|
- order; remapped to TP3's BP+4 rule when the
|
|
|
- list has been read (see ProcFunc) *)
|
|
|
-
|
|
|
- tmpA, tmpB : CARDINAL ; (* global scratch word addresses *)
|
|
|
- crtAttrOff : CARDINAL ; (* image offset of the text attribute byte that
|
|
|
- LowVideo/NormVideo set and ClrScr/ClrEol use *)
|
|
|
-
|
|
|
- hdrFlag, hdrCS, hdrDS, hdrHeap, hdrMax : CARDINAL ;
|
|
|
-
|
|
|
- kName : ARRAY [0..42] OF ARRAY [0..15] OF CHAR ;
|
|
|
- kTk : ARRAY [0..42] OF CARDINAL ;
|
|
|
-
|
|
|
(* ---------------------------------------------------------------- *)
|
|
|
(* small char helpers *)
|
|
|
(* ---------------------------------------------------------------- *)
|
|
|
@@ -878,5074 +646,696 @@ END EmRet ;
|
|
|
(* forward declarations *)
|
|
|
(* ---------------------------------------------------------------- *)
|
|
|
|
|
|
-PROCEDURE ParseExpr (VAR r : ERes) ; FORWARD ;
|
|
|
-PROCEDURE ParseAdd (VAR r : ERes) ; FORWARD ;
|
|
|
-PROCEDURE ParseMul (VAR r : ERes) ; FORWARD ;
|
|
|
-PROCEDURE ParseNeg (VAR r : ERes) ; FORWARD ;
|
|
|
-PROCEDURE ParseAtom (VAR r : ERes) ; FORWARD ;
|
|
|
PROCEDURE ParseType (VAR cls, size, elem : CARDINAL) ; FORWARD ;
|
|
|
PROCEDURE Statmnt () ; FORWARD ;
|
|
|
-PROCEDURE ParseCall (idx : CARDINAL) ; FORWARD ;
|
|
|
-PROCEDURE ParseCallArgs (idx : CARDINAL) ; FORWARD ;
|
|
|
-PROCEDURE EmCallMost (idx, cleanup : CARDINAL) ; FORWARD ;
|
|
|
PROCEDURE SlotSize (cls, size : CARDINAL) : CARDINAL ; FORWARD ;
|
|
|
PROCEDURE ParamSlotBytes (e : SymEntry) : CARDINAL ; FORWARD ;
|
|
|
-PROCEDURE NewScratchReal () : CARDINAL ; FORWARD ;
|
|
|
-PROCEDURE EmPushRealAddr (r : ERes) ; FORWARD ;
|
|
|
-PROCEDURE EmCopyRealTo (dstOff : CARDINAL ; r : ERes) ; FORWARD ;
|
|
|
-PROCEDURE RealBin (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ; FORWARD ;
|
|
|
-PROCEDURE RealUnary (ent : CARDINAL ; VAR r : ERes) ; FORWARD ;
|
|
|
-PROCEDURE IntToMbf (v : LONGINT ; VAR b : ARRAY OF CHAR) ; FORWARD ;
|
|
|
-
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-(* expressions (TPSRC9) *)
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-
|
|
|
-PROCEDURE VarSize (r : ERes) : CARDINAL ;
|
|
|
-(* The width of a kind-1 value. An element (`b[i]') or a field (`r.f') has a
|
|
|
- size of its own, which is NOT its variable's; when the parser has recorded
|
|
|
- one, it wins. Otherwise the variable's declared size is the answer. *)
|
|
|
+PROCEDURE ParseLabelStmt () ;
|
|
|
+(* numeric or named label definition 'n :' / 'Name:' *)
|
|
|
+VAR n : CARDINAL ;
|
|
|
+ nm : ARRAY [0..MaxName] OF CHAR ;
|
|
|
+ idx : CARDINAL ;
|
|
|
+ i : CARDINAL ;
|
|
|
BEGIN
|
|
|
- IF r.sz > 0 THEN
|
|
|
- RETURN r.sz
|
|
|
+ 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 ;
|
|
|
- RETURN symtab [r.idx].size
|
|
|
-END VarSize ;
|
|
|
+ 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 IsCharArray (r : ERes) : BOOLEAN ;
|
|
|
-(* A fixed `array[..] of char', as opposed to a counted STRING. *)
|
|
|
+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
|
|
|
- IF (r.cls # TArray) OR (r.arrIdx = 0) THEN
|
|
|
+ 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 ;
|
|
|
- RETURN arrs [r.arrIdx - 1].ecls = TChar
|
|
|
-END IsCharArray ;
|
|
|
-
|
|
|
-PROCEDURE LoadAtom (VAR r : ERes) ;
|
|
|
-(* load value of r into AX (folding constants).
|
|
|
-
|
|
|
- A string literal is refused here, and this is the single place that has to:
|
|
|
- assignment, IF, WHILE, FOR, REPEAT, CASE, array subscripts and every
|
|
|
- operator all reach their operand through LoadAtom, and none of them can use
|
|
|
- a counted string where a 16-bit word is expected. Reporting it here rather
|
|
|
- than in the parser means writeln('hi') still works - IoCall handles a
|
|
|
- literal before it ever calls LoadAtom. *)
|
|
|
-VAR emsz : CARDINAL ;
|
|
|
+ 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 (0ECH) ; (* IN AL,DX *)
|
|
|
- EmMovAh0 () ;
|
|
|
- r.kind := 2 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF r.cls = TString THEN
|
|
|
- Err (ENoLib) ; (* string value used as a number *)
|
|
|
- r.kind := 2 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF r.cls = TSet THEN
|
|
|
- (* A set is bytes, not a 16-bit value. It is legal as the right operand
|
|
|
- of `in' (and later as a whole-value operand of `+'/`*'/'='/assignment),
|
|
|
- all of which handle it BEFORE LoadAtom - but never as a number, which
|
|
|
- would otherwise load its first two bytes as if it were an integer. *)
|
|
|
- Err (ENoLib) ;
|
|
|
- r.kind := 2 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF r.kind = 5 THEN
|
|
|
- (* An element whose address ParseSub computed into DI (LEA DI,[base] /
|
|
|
- ADD DI,AX): a string character, or an array element of one or two
|
|
|
- bytes. Zeroing AH keeps a one-byte value a clean 16-bit char. The
|
|
|
- read must happen HERE, before anything else is emitted: the caller
|
|
|
- reaches this immediately after parsing the subscript, or - for a
|
|
|
- binary operator - SaveLeft has already materialised it, so DI is
|
|
|
- still the element's address. *)
|
|
|
- IF VarSize (r) > 2 THEN
|
|
|
- Err (ENoLib) ; (* a whole record/array as a value *)
|
|
|
- r.kind := 2 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF VarSize (r) = 2 THEN
|
|
|
- EmLdAxDi ()
|
|
|
- ELSE
|
|
|
- EmLdAlDi () ;
|
|
|
- EmMovAh0 ()
|
|
|
- END ;
|
|
|
- r.kind := 2 ;
|
|
|
+ Ebyte (0EEH) ; (* OUT DX,AL *)
|
|
|
RETURN
|
|
|
END ;
|
|
|
- IF r.kind = 0 THEN
|
|
|
- EmMovAxi (W16 (r.imm)) ;
|
|
|
- r.kind := 2
|
|
|
- ELSIF r.kind = 1 THEN
|
|
|
- IF symtab [r.idx].isVar THEN
|
|
|
- (* A VAR parameter: [BP+off] holds the address, and the value is one
|
|
|
- level down. r.boff is necessarily 0 - a by-reference parameter is
|
|
|
- a scalar in this increment, so it has nothing to subscript. *)
|
|
|
- IF r.boff # 0 THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- r.kind := 2 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- EmLoadVarIndSym (r.idx, VarSize (r)) ;
|
|
|
- r.kind := 2 ;
|
|
|
+ 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 (VarSize (r) > 2) AND NOT
|
|
|
- ((r.cls = TChar) AND (symtab [r.idx].cls = TString)) THEN
|
|
|
- Err (ENoLib)
|
|
|
- ELSE
|
|
|
- (* s[i] indexes one byte of a string, not the string, so its width is
|
|
|
- one whatever the variable's declared width is. *)
|
|
|
- emsz := VarSize (r) ;
|
|
|
- IF (r.cls = TChar) AND (symtab [r.idx].cls = TString) THEN
|
|
|
- emsz := 1
|
|
|
- END ;
|
|
|
- LoadSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, emsz) ;
|
|
|
- IF emsz = 1 THEN
|
|
|
- EmMovAh0 ()
|
|
|
- END ;
|
|
|
- r.kind := 2
|
|
|
- END
|
|
|
- END
|
|
|
-END LoadAtom ;
|
|
|
-
|
|
|
-PROCEDURE EmitBoundsCheck (lo, hi, code : CARDINAL) ;
|
|
|
-(* `{$R+}' test: AX must be in [lo,hi]. The error path exits through
|
|
|
- runtime_error; the normal path jumps over the error stub. *)
|
|
|
-VAR jl, jg, over : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- IF NOT dirs.rng THEN RETURN END ;
|
|
|
- IF lo = hi THEN RETURN END ;
|
|
|
- EmCmpAxi (W16 (lo)) ; jl := EmJcc (8CH, 0) ;
|
|
|
- EmCmpAxi (W16 (hi)) ; jg := EmJcc (8FH, 0) ;
|
|
|
- over := EmJmpNear (0) ;
|
|
|
- SetPatTgt (jl, pc) ; SetPatTgt (jg, pc) ;
|
|
|
- EmMovAxi (code) ; DropC (EmCall (TU_RunErr)) ;
|
|
|
- SetPatTgt (over, pc)
|
|
|
-END EmitBoundsCheck ;
|
|
|
-
|
|
|
-PROCEDURE ParseSub (VAR r : ERes) ;
|
|
|
-(* consume '[' expr ']' while present.
|
|
|
-
|
|
|
- A CONSTANT index folds into the base offset boff, exactly as before. A
|
|
|
- VARIABLE index on a STRING cannot fold - off+i is a run-time value - so it
|
|
|
- is computed once here into DI and r.kind drops to 5, which is how LoadAtom,
|
|
|
- Assignment and IoCall are told the element's address is in DI. Arrays
|
|
|
- still accept only a constant index: a variable array subscript needs the
|
|
|
- element-size scaling that a one-byte string element does not, and it is
|
|
|
- item 2. *)
|
|
|
-VAR t : ERes ;
|
|
|
- ai, fi, nd, k, st, p : CARDINAL ;
|
|
|
- coff : LONGINT ;
|
|
|
- accOnStack, haveVar, more : BOOLEAN ;
|
|
|
- baseDI, found : BOOLEAN ;
|
|
|
-BEGIN
|
|
|
- LOOP
|
|
|
- Skip () ;
|
|
|
- IF ((r.cls = TPtr) OR ((r.kind = 1) AND (symtab [r.idx].cls = TPtr)))
|
|
|
- AND (CurCh () = '^') THEN
|
|
|
- (* Dereference after a variable, a field or an array element. The
|
|
|
- pointer word may be an ordinary symbol (kind 1) or the element
|
|
|
- address already in DI (kind 5, e.g. Friend[Index]^). *)
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- p := r.ptrElem ;
|
|
|
- IF p = 0 THEN
|
|
|
- p := symtab [r.idx].elem
|
|
|
- END ;
|
|
|
- IF r.kind = 5 THEN
|
|
|
- EmLdAxDi () ;
|
|
|
- ELSE
|
|
|
- LoadSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, 2)
|
|
|
- END ;
|
|
|
- EmMovDiAx () ;
|
|
|
- r.idx := p ;
|
|
|
- r.kind := 5 ;
|
|
|
- r.boff := 0 ;
|
|
|
- r.cls := symtab [p].cls ;
|
|
|
- r.sz := symtab [p].size ;
|
|
|
- r.fldFirst := symtab [p].fldFirst ;
|
|
|
- r.fldLast := symtab [p].fldLast ;
|
|
|
- r.arrIdx := symtab [p].arrIdx ;
|
|
|
- r.ptrElem := symtab [p].elem ;
|
|
|
- r.hasBounds := ((symtab [p].cls = TScalar) OR (symtab [p].cls = TEnum)
|
|
|
- OR (symtab [p].cls = TChar)) AND
|
|
|
- (symtab [p].lo # symtab [p].hi) ;
|
|
|
- r.blo := symtab [p].lo ; r.bhi := symtab [p].hi
|
|
|
- ELSIF CurCh () = '.' THEN
|
|
|
- (* FIELD selection: `r.f'. The field's offset adds to the record
|
|
|
- base's, and the value's class and WIDTH become the field's - which
|
|
|
- is the whole reason a width rides on the expression (VarSize). *)
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- Skip () ;
|
|
|
- IF NOT Alpha (CurCh ()) THEN
|
|
|
- Err (EUnknown) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- GetWord () ;
|
|
|
- IF r.fldFirst >= r.fldLast THEN
|
|
|
- Err (ESimpType) ; (* not a record *)
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- fi := r.fldFirst ;
|
|
|
- found := FALSE ;
|
|
|
- WHILE (fi < r.fldLast) AND NOT found DO
|
|
|
- IF NameEq (fields [fi].name, wrd) THEN
|
|
|
- found := TRUE
|
|
|
- ELSE
|
|
|
- INC (fi)
|
|
|
- END
|
|
|
- END ;
|
|
|
- IF NOT found THEN
|
|
|
- Err (EUnknown) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF r.kind = 5 THEN
|
|
|
- (* The element's address is in DI: a field is a fixed offset from
|
|
|
- it. The array symbol already carries the element record's
|
|
|
- field range (DefVar copies recFldFirst/recFldLast), which is
|
|
|
- why the lookup above works for `Sheet[I,J].Field' too. *)
|
|
|
- IF fields [fi].off # 0 THEN
|
|
|
- EmAddDiImm (fields [fi].off)
|
|
|
- END
|
|
|
- ELSE
|
|
|
- r.boff := W16 (VAL (LONGINT, r.boff)
|
|
|
- + VAL (LONGINT, fields [fi].off)) ;
|
|
|
- END ;
|
|
|
- r.cls := fields [fi].cls ;
|
|
|
- r.sz := fields [fi].size ;
|
|
|
- r.fldFirst := fields [fi].fldFirst ;
|
|
|
- r.fldLast := fields [fi].fldLast ;
|
|
|
- r.arrIdx := fields [fi].arrIdx ;
|
|
|
- r.ptrElem := fields [fi].ptrElem ;
|
|
|
- r.hasBounds := ((fields [fi].cls = TScalar) OR (fields [fi].cls = TEnum)
|
|
|
- OR (fields [fi].cls = TChar)) AND
|
|
|
- (fields [fi].lo # fields [fi].hi) ;
|
|
|
- r.blo := fields [fi].lo ; r.bhi := fields [fi].hi ;
|
|
|
- IF r.cls = TSet THEN
|
|
|
- (* ParseVar set setoff only when the SYMBOL itself was a set; for
|
|
|
- an array/record the class was still TArray/TRecord then, so the
|
|
|
- base offset has to be recorded now. *)
|
|
|
- r.setoff := symtab [r.idx].off ;
|
|
|
- r.setbase := fields [fi].elem ;
|
|
|
- r.setsize := fields [fi].size
|
|
|
- END
|
|
|
- ELSIF CurCh () = '[' THEN
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- IF r.cls = TString THEN
|
|
|
- (* s[i]: a STRING is a length byte at s[0] followed by the
|
|
|
- characters, so index i selects the one byte at off+i. A second
|
|
|
- subscript on a character is not a type. *)
|
|
|
- ParseExpr (t) ;
|
|
|
- IF OK () THEN
|
|
|
- IF r.cls = TChar THEN
|
|
|
- Err (ESimpType) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF symtab [r.idx].isVar THEN
|
|
|
- (* VAR string parameter: the base is the address in the
|
|
|
- parameter slot, not LEA of the slot. Compute DI once for
|
|
|
- both constant and variable indices, so LoadAtom and
|
|
|
- Assignment see the same kind-5 character address they do
|
|
|
- for an ordinary string. *)
|
|
|
- LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
|
|
|
- EmMovDiAx () ;
|
|
|
- IF t.kind = 0 THEN
|
|
|
- EmAddDiImm ((r.boff + W16 (t.imm)) MOD 10000H)
|
|
|
- ELSE
|
|
|
- IF r.boff # 0 THEN
|
|
|
- EmAddDiImm (r.boff)
|
|
|
- END ;
|
|
|
- LoadAtom (t) ;
|
|
|
- EmAddDiAx ()
|
|
|
- END ;
|
|
|
- r.kind := 5
|
|
|
- ELSIF t.kind = 0 THEN
|
|
|
- (* constant index: fold it into boff, as an array's does, and
|
|
|
- r.cls drops to TChar so every consumer below - LoadAtom,
|
|
|
- Assignment, IoCall - sees a one-byte value instead of the
|
|
|
- whole string. *)
|
|
|
- IF dirs.rng AND ((t.imm < 1) OR (t.imm > VAL (LONGINT, VarSize (r) - 1))) THEN
|
|
|
- Err (EConstRange) ; RETURN
|
|
|
- END ;
|
|
|
- r.boff := W16 (VAL (LONGINT, r.boff) + t.imm)
|
|
|
- ELSE
|
|
|
- (* Variable index. Compute the element address once, now:
|
|
|
- the index is evaluated into AX (LoadAtom is a no-op for a
|
|
|
- kind-2 value and re-reads [DI] for a nested subscript), then
|
|
|
- DI := base + AX. This is TP3's indstr/ialoop shape (TPSRC9
|
|
|
- 1100-1111, 1200-1229), which likewise holds the address in
|
|
|
- DI until the byte is loaded or stored; a register is what
|
|
|
- lets a later LoadAtom read [DI] and a later assignment PUSH
|
|
|
- DI across its right-hand side. *)
|
|
|
- LoadAtom (t) ;
|
|
|
- IF dirs.rng THEN
|
|
|
- EmPushAx () ;
|
|
|
- IF symtab [r.idx].isVar THEN
|
|
|
- LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
|
|
|
- EmPushAx ()
|
|
|
- ELSE
|
|
|
- EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
|
|
|
- END ;
|
|
|
- DropC (EmCall (TU_StrIndex)) ;
|
|
|
- EmAddSp (4)
|
|
|
- END ;
|
|
|
- LeaDiSym (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
|
|
|
- EmAddDiAx () ;
|
|
|
- r.kind := 5
|
|
|
- END ;
|
|
|
- r.cls := TChar ;
|
|
|
- r.sz := 1
|
|
|
- END ;
|
|
|
- ExpectDelim (']', ENoSemi)
|
|
|
- ELSIF r.arrIdx > 0 THEN
|
|
|
- (* An array subscript LIST: one expression per dimension, comma
|
|
|
- separated. The byte offset is
|
|
|
- sum over k of (i[k] - lo[k]) * stride[k]
|
|
|
- where stride[k] is the element size times the count of every
|
|
|
- LATER dimension (row-major: the LAST dimension varies fastest).
|
|
|
- A constant index folds into coff; a run-time one is scaled as
|
|
|
- soon as it is parsed and summed on the STACK, because parsing
|
|
|
- the next index may clobber AX and DI. *)
|
|
|
- baseDI := (r.kind = 5) ;
|
|
|
- ai := r.arrIdx - 1 ;
|
|
|
- nd := 0 ;
|
|
|
- coff := 0 ;
|
|
|
- accOnStack := FALSE ;
|
|
|
- haveVar := FALSE ;
|
|
|
- LOOP
|
|
|
- IF nd >= arrs [ai].n THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (t) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- Skip () ;
|
|
|
- IF CurCh () = ':' THEN
|
|
|
- (* TP3 segment:offset form in Mem[...]; the segment
|
|
|
- expression is consumed and the offset is the index. *)
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- ParseExpr (t) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END
|
|
|
- END ;
|
|
|
- st := arrs [ai].elem ;
|
|
|
- k := nd + 1 ;
|
|
|
- WHILE k < arrs [ai].n DO
|
|
|
- st := st * W16 (arrs [ai].hi [k] - arrs [ai].lo [k] + 1) ;
|
|
|
- INC (k)
|
|
|
- END ;
|
|
|
- Skip () ;
|
|
|
- more := CurCh () = ',' ;
|
|
|
- IF t.kind = 0 THEN
|
|
|
- IF dirs.rng AND ((t.imm < arrs [ai].lo [nd]) OR
|
|
|
- (t.imm > arrs [ai].hi [nd])) THEN
|
|
|
- Err (EConstRange) ; RETURN
|
|
|
- END ;
|
|
|
- coff := coff + (t.imm - arrs [ai].lo [nd])
|
|
|
- * VAL (LONGINT, st)
|
|
|
- ELSE
|
|
|
- LoadAtom (t) ;
|
|
|
- EmitBoundsCheck (arrs [ai].lo [nd], arrs [ai].hi [nd], 16) ;
|
|
|
- IF arrs [ai].lo [nd] # 0 THEN
|
|
|
- EmMovCxi (W16 (arrs [ai].lo [nd])) ;
|
|
|
- EmSubAxCx ()
|
|
|
- END ;
|
|
|
- IF st # 1 THEN
|
|
|
- EmMovCxi (st) ;
|
|
|
- EmMulAxCx ()
|
|
|
- END ;
|
|
|
- IF more THEN
|
|
|
- (* the next dimension's expression will clobber AX: park
|
|
|
- the running sum. A SINGLE index skips this entirely,
|
|
|
- so 1-D code is byte-identical to the old path. *)
|
|
|
- IF accOnStack THEN
|
|
|
- EmPopCx () ;
|
|
|
- EmAddAxCx () ;
|
|
|
- EmPushAx ()
|
|
|
- ELSE
|
|
|
- EmPushAx () ;
|
|
|
- accOnStack := TRUE
|
|
|
- END
|
|
|
- ELSE
|
|
|
- (* last dimension: AX is the total *)
|
|
|
- IF accOnStack THEN
|
|
|
- EmPopCx () ;
|
|
|
- EmAddAxCx () ;
|
|
|
- accOnStack := FALSE
|
|
|
- END ;
|
|
|
- haveVar := TRUE
|
|
|
- END
|
|
|
- END ;
|
|
|
- INC (nd) ;
|
|
|
- IF more THEN
|
|
|
- DropCh (GetCh ())
|
|
|
+ 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
|
|
|
- EXIT
|
|
|
+ EmMovAxi (ORD (strPool [strOff [src.strx] + k])) ;
|
|
|
+ StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1)
|
|
|
END
|
|
|
- END ;
|
|
|
- IF nd # arrs [ai].n THEN
|
|
|
- (* fewer subscripts than dimensions: the value would be a
|
|
|
- sub-array, which has no scalar representation *)
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ExpectDelim (']', ENoSemi) ;
|
|
|
- IF accOnStack THEN
|
|
|
- (* the last dimensions were constant: the parked sum is still
|
|
|
- on the stack, and AX is the total *)
|
|
|
- EmPopAx () ;
|
|
|
- accOnStack := FALSE
|
|
|
- END ;
|
|
|
- IF baseDI THEN
|
|
|
- (* The base address is already in DI: a pointer dereference
|
|
|
- (`Buffer^[i]'). Add the computed byte offset to it; a
|
|
|
- constant-only index can use ADD DI,imm16. *)
|
|
|
- IF haveVar THEN
|
|
|
- EmAddDiAx ()
|
|
|
- ELSE
|
|
|
- IF coff # 0 THEN
|
|
|
- EmAddDiImm (W16 (coff))
|
|
|
- END
|
|
|
- END ;
|
|
|
- r.kind := 5
|
|
|
- ELSIF haveVar THEN
|
|
|
- LeaDiSym (r.idx, (symtab [r.idx].off + r.boff
|
|
|
- + W16 (coff)) MOD 10000H) ;
|
|
|
- EmAddDiAx () ;
|
|
|
- r.kind := 5
|
|
|
ELSE
|
|
|
- r.boff := W16 (VAL (LONGINT, r.boff) + coff)
|
|
|
- END ;
|
|
|
- r.sz := arrs [ai].elem ;
|
|
|
- r.cls := arrs [ai].ecls ;
|
|
|
- r.fldFirst := arrs [ai].fldFirst ;
|
|
|
- r.fldLast := arrs [ai].fldLast ;
|
|
|
- r.arrIdx := 0 ;
|
|
|
- r.ptrElem := arrs [ai].elemType ;
|
|
|
- r.hasBounds := ((arrs [ai].ecls = TScalar) OR (arrs [ai].ecls = TEnum)
|
|
|
- OR (arrs [ai].ecls = TChar)) AND
|
|
|
- (arrs [ai].elemLo # arrs [ai].elemHi) ;
|
|
|
- r.blo := arrs [ai].elemLo ; r.bhi := arrs [ai].elemHi
|
|
|
- ELSE
|
|
|
- ParseExpr (t) ;
|
|
|
- IF OK () THEN
|
|
|
- IF t.kind # 0 THEN
|
|
|
- Err (ENoLib)
|
|
|
+ IF r.kind = 5 THEN
|
|
|
+ EmStDiImm (k, ORD (' '))
|
|
|
ELSE
|
|
|
- Err (ESimpType)
|
|
|
+ EmMovAxi (ORD (' ')) ;
|
|
|
+ StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1)
|
|
|
END
|
|
|
END ;
|
|
|
- ExpectDelim (']', ENoSemi)
|
|
|
- END
|
|
|
- ELSE
|
|
|
+ INC (k)
|
|
|
+ END ;
|
|
|
RETURN
|
|
|
- END
|
|
|
- END
|
|
|
-END ParseSub ;
|
|
|
-
|
|
|
-PROCEDURE ParseVar (VAR r : ERes) ;
|
|
|
-(* name [ '[' constExpr ']' ]* ; a function name maps to its result var *)
|
|
|
-VAR idx, p : CARDINAL ;
|
|
|
- t : ERes ;
|
|
|
-BEGIN
|
|
|
- IF NOT Search (wrd, idx) THEN
|
|
|
- Err (EUnknown) ;
|
|
|
+ END ;
|
|
|
+ Err (ETypeErr) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- IF symtab [idx].isPort THEN
|
|
|
- (* TP3's Port[address]: a byte-wide pseudo-array implemented with IN/OUT.
|
|
|
- The index is evaluated once into the compiler scratch word; assignment
|
|
|
- and LoadAtom turn it into OUT DX,AL / IN AL,DX. *)
|
|
|
- Skip () ;
|
|
|
- IF CurCh () # '[' THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
+ 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 ;
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- ParseExpr (t) ;
|
|
|
- IF NOT OK () THEN RETURN END ;
|
|
|
- IF (t.cls # TScalar) AND (t.cls # TChar) THEN
|
|
|
+ IF (src.kind # 1) AND (src.kind # 5) THEN
|
|
|
Err (ETypeErr) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- LoadAtom (t) ;
|
|
|
- EmStoreVar (FALSE, symtab [tmpA].off, 2) ;
|
|
|
- ExpectDelim (']', ENoSemi) ;
|
|
|
- r.kind := 1 ;
|
|
|
- r.idx := idx ;
|
|
|
- r.cls := TScalar ;
|
|
|
- r.sz := 1 ;
|
|
|
- r.boff := 0 ;
|
|
|
- r.hasBounds := FALSE ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF symtab [idx].cls = TPtr THEN
|
|
|
- Skip () ;
|
|
|
- IF CurCh () = '^' THEN
|
|
|
- (* Dereference: the pointer word is the base address. r.idx becomes
|
|
|
- the pointee TYPE symbol, because ParseSub reads an array/record's
|
|
|
- metadata from the symbol, not from the expression. *)
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- p := symtab [idx].elem ;
|
|
|
- LoadSymVar (idx, symtab [idx].off, 2) ;
|
|
|
- EmMovDiAx () ;
|
|
|
- r.idx := p ;
|
|
|
- r.kind := 5 ;
|
|
|
- r.boff := 0 ;
|
|
|
- r.cls := symtab [p].cls ;
|
|
|
- r.sz := symtab [p].size ;
|
|
|
- r.fldFirst := symtab [p].fldFirst ;
|
|
|
- r.fldLast := symtab [p].fldLast ;
|
|
|
- r.arrIdx := symtab [p].arrIdx ;
|
|
|
- r.ptrElem := symtab [p].elem ;
|
|
|
- r.hasBounds := ((symtab [p].cls = TScalar) OR (symtab [p].cls = TEnum)
|
|
|
- OR (symtab [p].cls = TChar)) AND
|
|
|
- (symtab [p].lo # symtab [p].hi) ;
|
|
|
- r.blo := symtab [p].lo ; r.bhi := symtab [p].hi ;
|
|
|
- ParseSub (r) ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- END ;
|
|
|
- r.idx := idx ;
|
|
|
- r.kind := 1 ;
|
|
|
- r.boff := 0 ;
|
|
|
- r.cls := symtab [idx].cls ;
|
|
|
- IF symtab [idx].tag = KFunc THEN
|
|
|
- idx := symtab [idx].resvar ;
|
|
|
- r.idx := idx ;
|
|
|
- r.cls := symtab [idx].cls
|
|
|
- ELSIF (symtab [idx].tag # KVar) AND (symtab [idx].tag # KType) THEN
|
|
|
- Err (EUnknown) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF r.cls = TSet THEN
|
|
|
- (* a set value: carry where its bytes are so ParseCmp can fold `in' and
|
|
|
- (later) compare. A set VARIABLE is still refused at its declaration,
|
|
|
- so today this is a typed constant or an inline literal. *)
|
|
|
- r.setoff := symtab [r.idx].off ;
|
|
|
- r.setbase := symtab [r.idx].elem ;
|
|
|
- r.setsize := symtab [r.idx].size
|
|
|
- END ;
|
|
|
- r.sz := symtab [r.idx].size ;
|
|
|
- r.fldFirst := symtab [r.idx].fldFirst ;
|
|
|
- r.fldLast := symtab [r.idx].fldLast ;
|
|
|
- r.arrIdx := symtab [r.idx].arrIdx ;
|
|
|
- r.ptrElem := symtab [r.idx].elem ;
|
|
|
- r.hasBounds := ((symtab [r.idx].cls = TScalar) OR (symtab [r.idx].cls = TEnum)
|
|
|
- OR (symtab [r.idx].cls = TChar)) AND
|
|
|
- (symtab [r.idx].lo # symtab [r.idx].hi) ;
|
|
|
- r.blo := symtab [r.idx].lo ; r.bhi := symtab [r.idx].hi ;
|
|
|
- ParseSub (r)
|
|
|
-END ParseVar ;
|
|
|
-
|
|
|
-PROCEDURE ConstAdd (a, b : LONGINT) : LONGINT ;
|
|
|
-BEGIN
|
|
|
- RETURN VAL (LONGINT, W16 (a + b))
|
|
|
-END ConstAdd ;
|
|
|
-
|
|
|
-PROCEDURE ConstSub (a, b : LONGINT) : LONGINT ;
|
|
|
-BEGIN
|
|
|
- RETURN VAL (LONGINT, W16 (a - b))
|
|
|
-END ConstSub ;
|
|
|
-
|
|
|
-PROCEDURE ConstMul (a, b : LONGINT) : LONGINT ;
|
|
|
-BEGIN
|
|
|
- RETURN VAL (LONGINT, W16 (a * b))
|
|
|
-END ConstMul ;
|
|
|
-
|
|
|
-PROCEDURE EmXchgAxDx () ;
|
|
|
-(* 92h = XCHG AX,DX. Named for what it EMITS, which is the point of the
|
|
|
- whole naming convention: this used to be called EmMoveAxDx, which is what
|
|
|
- somebody would expect the opcode to be, and it is not - 89 D8 is
|
|
|
- MOV AX,DX, 92h is the exchange. Here the exchange is what is wanted, so
|
|
|
- the name is the only thing that was wrong, and it was wrong in the exact
|
|
|
- way this file's names are not allowed to be: reading as "a move" when it
|
|
|
- is a swap. After EmIDivAxCx the remainder is in DX and `mod` wants it in
|
|
|
- AX; an exchange gets it there in one byte where a move also would, so the
|
|
|
- behaviour is identical either way and only the name lied. *)
|
|
|
-BEGIN
|
|
|
- Ebyte (92H)
|
|
|
-END EmXchgAxDx ;
|
|
|
-
|
|
|
-PROCEDURE StrConcat (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ; FORWARD ;
|
|
|
-PROCEDURE StrOperand (r : ERes) : BOOLEAN ; FORWARD ;
|
|
|
-
|
|
|
-PROCEDURE BinOpEmit (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ;
|
|
|
-(* binary operation at one precedence level; folds constant operands *)
|
|
|
-VAR f : LONGINT ;
|
|
|
- okc : BOOLEAN ;
|
|
|
-BEGIN
|
|
|
- IF (left.cls = TReal) OR (right.cls = TReal) OR (op = OpDiv) THEN
|
|
|
- (* `/` is real division even when both operands are integers; Pascal's
|
|
|
- `div` is the integer operator and has its own token. *)
|
|
|
- RealBin (op, left, right, res) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF StrOperand (left) OR StrOperand (right) THEN
|
|
|
- (* A string OPERAND - a STRING or a CHAR, which is a one-character string
|
|
|
- for this purpose - makes this a string operation, and `+' is the only
|
|
|
- one ISO Modula-2 defines: every other binary operator reached here
|
|
|
- (OR, and the multiplicative and additive numeric ops) has no meaning
|
|
|
- over a STRING, and StrConcat rejects it.
|
|
|
-
|
|
|
- The test is StrOperand and NOT `cls = TString' because of the two
|
|
|
- CHAR operands. `'a' + 'b'' has no STRING in it at all, so a
|
|
|
- TString-only test let it fall through to the integer path, where the
|
|
|
- character codes were added and CHR(195) was printed - a silently
|
|
|
- wrong program rather than an error (see t53_strcat_type). A CHAR
|
|
|
- operand is still a string operand, which is also what makes `a + ch'
|
|
|
- concatenate.
|
|
|
-
|
|
|
- Handling it here, at the head of the one routine every binary
|
|
|
- operator funnels through, is what keeps `a + b', `writeln(a + b)',
|
|
|
- `(a + b) = c' and `s := a + b + c' all going through the same
|
|
|
- emission. *)
|
|
|
- StrConcat (op, left, right, res) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF op = TkAnd THEN
|
|
|
- IF (left.kind = 0) AND (right.kind = 0) THEN
|
|
|
- res.kind := 0 ;
|
|
|
- res.imm := BitAnd (left.imm, right.imm) ;
|
|
|
- IF (left.cls = TBool) OR (right.cls = TBool) THEN
|
|
|
- res.cls := TBool
|
|
|
- ELSE
|
|
|
- res.cls := left.cls
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadPair (left, right) ;
|
|
|
- EmAndAxCx () ;
|
|
|
- res.kind := 2 ;
|
|
|
- IF (left.cls = TBool) OR (right.cls = TBool) THEN
|
|
|
- res.cls := TBool
|
|
|
- ELSE
|
|
|
- res.cls := left.cls
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF op = TkOr THEN
|
|
|
- IF (left.kind = 0) AND (right.kind = 0) THEN
|
|
|
- res.kind := 0 ;
|
|
|
- res.imm := BitOr (left.imm, right.imm) ;
|
|
|
- IF (left.cls = TBool) OR (right.cls = TBool) THEN
|
|
|
- res.cls := TBool
|
|
|
- ELSE
|
|
|
- res.cls := left.cls
|
|
|
- END ;
|
|
|
+ IF VarSize (src) # VarSize (r) THEN
|
|
|
+ Err (ETypeErr) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- LoadPair (left, right) ;
|
|
|
- EmOrAxCx () ;
|
|
|
- res.kind := 2 ;
|
|
|
- IF (left.cls = TBool) OR (right.cls = TBool) THEN
|
|
|
- res.cls := TBool
|
|
|
+ IF src.kind = 5 THEN
|
|
|
+ EmPushDi ()
|
|
|
ELSE
|
|
|
- res.cls := left.cls
|
|
|
+ EmPushSymAddr (src.idx, (symtab [src.idx].off + src.boff) MOD 10000H)
|
|
|
END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF (left.kind = 0) AND (right.kind = 0) THEN
|
|
|
- okc := FALSE ;
|
|
|
- CASE op OF
|
|
|
- OpAdd : f := ConstAdd (left.imm, right.imm) ; okc := TRUE ;
|
|
|
- | OpSub : f := ConstSub (left.imm, right.imm) ; okc := TRUE ;
|
|
|
- | OpMul : f := ConstMul (left.imm, right.imm) ; okc := TRUE ;
|
|
|
- | TkDiv : okc := (right.imm # 0) AND (right.imm > 0)
|
|
|
- AND (left.imm >= 0) ;
|
|
|
- IF okc THEN f := left.imm DIV right.imm END ;
|
|
|
- | TkMod : okc := (right.imm # 0) AND (right.imm > 0)
|
|
|
- AND (left.imm >= 0) ;
|
|
|
- IF okc THEN f := left.imm MOD right.imm END ;
|
|
|
+ IF r.kind = 5 THEN
|
|
|
+ (* stack now holds dest, source; make it source, dest for the ABI *)
|
|
|
+ EmPopAx () ;
|
|
|
+ EmPopBx () ;
|
|
|
+ EmPushAx () ;
|
|
|
+ EmPushBx ()
|
|
|
ELSE
|
|
|
- okc := FALSE
|
|
|
+ EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
|
|
|
END ;
|
|
|
- IF okc THEN
|
|
|
- res.kind := 0 ;
|
|
|
- res.imm := VAL (LONGINT, W16 (f)) ;
|
|
|
- res.cls := left.cls ;
|
|
|
- RETURN
|
|
|
- ELSIF op = TkDiv THEN
|
|
|
- Err (EConstRange) ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- END ;
|
|
|
- LoadPair (left, right) ;
|
|
|
- CASE op OF
|
|
|
- OpAdd : EmAddAxCx ;
|
|
|
- | OpSub : EmSubAxCx ;
|
|
|
- | OpMul : EmMulAxCx ;
|
|
|
- | OpShl : EmShlAxCl ;
|
|
|
- | OpShr : EmShrAxCl ;
|
|
|
- | TkDiv : EmIDivAxCx ;
|
|
|
- | TkMod : EmIDivAxCx ; EmXchgAxDx ;
|
|
|
- ELSE
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- res.kind := 2 ;
|
|
|
- res.cls := left.cls
|
|
|
-END BinOpEmit ;
|
|
|
-
|
|
|
-PROCEDURE ConstCmp (op : CARDINAL ; a, b : LONGINT ; VAR f : LONGINT)
|
|
|
- : BOOLEAN ;
|
|
|
-VAR a16, b16 : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- a16 := W16 (a) ;
|
|
|
- b16 := W16 (b) ;
|
|
|
- f := 0 ;
|
|
|
- CASE op OF
|
|
|
- 1 : f := VAL (LONGINT, ORD (a16 = b16)) ;
|
|
|
- | 2 : f := VAL (LONGINT, ORD (a16 # b16)) ;
|
|
|
- | 3 : f := VAL (LONGINT, ORD (a16 < b16)) ;
|
|
|
- | 4 : f := VAL (LONGINT, ORD (a16 >= b16)) ;
|
|
|
- | 5 : f := VAL (LONGINT, ORD (a16 > b16)) ;
|
|
|
- | 6 : f := VAL (LONGINT, ORD (a16 <= b16)) ;
|
|
|
- ELSE
|
|
|
- RETURN FALSE
|
|
|
- END ;
|
|
|
- RETURN TRUE
|
|
|
-END ConstCmp ;
|
|
|
-
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-(* keeping an operand alive across the parse of the other one *)
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-
|
|
|
-PROCEDURE SaveLeft (VAR left : ERes) ;
|
|
|
-VAR sk : CARDINAL ;
|
|
|
-(* Called the moment the operator has been recognised, i.e. *before* the
|
|
|
- right-hand operand is parsed.
|
|
|
-
|
|
|
- Every binary level in this parser has the shape
|
|
|
-
|
|
|
- left := r ; ParseXxx (right) ; BinOpEmit (op, left, right, r) ;
|
|
|
-
|
|
|
- so the right-hand operand's code is emitted between those two lines, and
|
|
|
- the left-hand operand has to survive that. For kind 0 (a constant) and
|
|
|
- kind 1 (a named variable) there is nothing to survive: LoadAtom re-emits
|
|
|
- the MOV or the load at the operator site, and no code has been emitted
|
|
|
- for the left yet. A kind-2 value is different - its code is already in
|
|
|
- the image and its value exists only in AX, which the right-hand parse is
|
|
|
- about to overwrite. The value had to be parked on the stack instead.
|
|
|
-
|
|
|
- TPSRC9 does exactly this in the other order: addptr and mulptr CALL
|
|
|
- pushres (which calls loadatom and sets flgpshax) *before* CALL mullevel,
|
|
|
- so PUSH AX lands in the image ahead of the right-hand operand's code.
|
|
|
- Without this, `(p > q) or (q > p)` emitted both comparisons and then
|
|
|
- ORed the *second* comparison's result with itself - which is why it
|
|
|
- printed FALSE for TRUE or FALSE. *)
|
|
|
-BEGIN
|
|
|
- IF left.cls = TReal THEN
|
|
|
- (* Park six bytes in a fresh scratch, exactly as kind-5 does for a
|
|
|
- scalar: the right-hand parse may reuse DI or call a routine. *)
|
|
|
- sk := NewScratchReal () ;
|
|
|
- EmCopyRealTo (symtab [sk].off, left) ;
|
|
|
- left.idx := sk ;
|
|
|
- left.kind := 1 ;
|
|
|
- left.cls := TReal ;
|
|
|
- left.sz := 6 ;
|
|
|
- left.boff := 0
|
|
|
- ELSIF left.kind = 2 THEN
|
|
|
- EmPushAx () ;
|
|
|
- left.kind := 4 (* 4 = on the top of the stack *)
|
|
|
- ELSIF left.kind = 5 THEN
|
|
|
- (* A string element whose address is in DI. This is the one place the
|
|
|
- address must be spent BEFORE the right-hand operand is parsed: DI
|
|
|
- cannot survive it, because the right operand may hold a subscript of
|
|
|
- its own (which reuses DI) or call a routine (which may clobber it).
|
|
|
- Reading [DI] now - which LoadAtom does, turning kind 5 into kind 2 -
|
|
|
- and pushing the value is exactly what the kind-2 case above does
|
|
|
- next, so the two branches converge on kind 4. A subscript on the
|
|
|
- RIGHT is fine: it sets DI after this point and LoadPair reads it
|
|
|
- immediately, with no parse in between. *)
|
|
|
- LoadAtom (left) ; (* AL := [DI], AH := 0; kind := 2 *)
|
|
|
- EmPushAx () ;
|
|
|
- left.kind := 4
|
|
|
- END
|
|
|
-END SaveLeft ;
|
|
|
-
|
|
|
-PROCEDURE LoadPair (VAR left, right : ERes) ;
|
|
|
-(* Materialise both operands of a binary operator so that, once this
|
|
|
- returns, AX holds the LEFT one and CX the RIGHT one - which is the state
|
|
|
- EmAddAxCx/EmSubAxCx/EmMulAxCx/EmIDivAxCx/EmAndAxCx/EmOrAxCx/EmCmpAxCx
|
|
|
- all expect (see EmXchgAxCx).
|
|
|
-
|
|
|
- Three shapes, and only three:
|
|
|
-
|
|
|
- left.kind = 4 SaveLeft pushed it before the right operand was
|
|
|
- parsed, so the right value is in AX and the left one
|
|
|
- is on the stack: load the right (a no-op for kind 2),
|
|
|
- pop the left into CX, then swap.
|
|
|
- right.kind = 2 The right value is in AX, and loading the left would
|
|
|
- destroy it: push the right, load the left, then pop
|
|
|
- the right straight into CX. No swap needed.
|
|
|
- neither Both can still be materialised from scratch, and
|
|
|
- neither is at risk, so this is the original sequence.
|
|
|
-
|
|
|
- A kind-5 right-hand operand takes that last shape, and is safe there: the
|
|
|
- only instruction emitted before its LoadAtom is the left's, and MOV AX,[var]
|
|
|
- and MOV AX,imm do not touch DI, so [DI] still holds the element address.
|
|
|
-
|
|
|
- Whichever shape is taken, exactly one push is matched by exactly one
|
|
|
- pop. *)
|
|
|
-BEGIN
|
|
|
- IF left.kind = 4 THEN
|
|
|
- LoadAtom (right) ;
|
|
|
- EmPopCx () ;
|
|
|
- EmXchgAxCx ()
|
|
|
- ELSIF right.kind = 2 THEN
|
|
|
- EmPushAx () ;
|
|
|
- LoadAtom (left) ;
|
|
|
- EmPopCx ()
|
|
|
- ELSE
|
|
|
- LoadAtom (left) ; EmPushAx () ;
|
|
|
- LoadAtom (right) ; EmPopCx () ;
|
|
|
- EmXchgAxCx ()
|
|
|
- END
|
|
|
-END LoadPair ;
|
|
|
-
|
|
|
-PROCEDURE EmStrBlob (r : ERes) : CARDINAL ;
|
|
|
-(* Emit a string literal's <len><chars> in the code stream behind a JMP and
|
|
|
- return the image offset of the LENGTH byte. Shared by EmPushStrAddr (which
|
|
|
- pushes that address) and EmPushStrSlot (which copies the bytes onto the
|
|
|
- stack for a string value parameter). *)
|
|
|
-VAR n, len, here : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- len := strLen [r.strx] ;
|
|
|
- IF len > 255 THEN
|
|
|
- (* As in IoCall: the length is one byte, so a longer literal would wrap
|
|
|
- and silently carry only its first (length MOD 256) characters.
|
|
|
- TP3 strings are at most 255 characters. *)
|
|
|
- Err (EConstRange) ;
|
|
|
- RETURN 0
|
|
|
- END ;
|
|
|
- IF len + 1 <= 127 THEN
|
|
|
- Ebyte (0EBH) ; Ebyte (VAL (BYTE, len + 1)) (* JMP rel8 over it *)
|
|
|
- ELSE
|
|
|
- Ebyte (0E9H) ; Eword (len + 1) (* JMP rel16 over it *)
|
|
|
- END ;
|
|
|
- here := pc ; (* the length byte: the literal's address *)
|
|
|
- Ebyte (VAL (BYTE, len)) ;
|
|
|
- n := 0 ;
|
|
|
- WHILE n < len DO
|
|
|
- Ebyte (VAL (BYTE, ORD (strPool [strOff [r.strx] + n]))) ;
|
|
|
- INC (n)
|
|
|
- END ;
|
|
|
- RETURN here
|
|
|
-END EmStrBlob ;
|
|
|
-
|
|
|
-PROCEDURE EmAsciiZLiteral (start, stop : CARDINAL) : CARDINAL ;
|
|
|
-(* Emit the source text [start,stop) as a NUL-terminated code-resident string
|
|
|
- behind a JMP and return its image offset. Used for REAL literals, which are
|
|
|
- parsed by the runtime's ascreal rather than by a host-side decimal parser. *)
|
|
|
-VAR here, n, len : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- len := stop - start ;
|
|
|
- IF len <= 126 THEN
|
|
|
- Ebyte (0EBH) ; Ebyte (VAL (BYTE, len + 1))
|
|
|
- ELSE
|
|
|
- Ebyte (0E9H) ; Eword (len + 1)
|
|
|
- END ;
|
|
|
- here := pc ;
|
|
|
- n := start ;
|
|
|
- WHILE n < stop DO
|
|
|
- Ebyte (VAL (BYTE, ORD (CharAt (n)))) ;
|
|
|
- INC (n)
|
|
|
- END ;
|
|
|
- Ebyte (0) ;
|
|
|
- RETURN here
|
|
|
-END EmAsciiZLiteral ;
|
|
|
-
|
|
|
-PROCEDURE EmPushSetAddr (r : ERes) ;
|
|
|
-(* Push the ADDRESS of a set value: the runtime's set entries take addresses.
|
|
|
- A set literal/typed constant is code-resident (kind 7), a set-expression
|
|
|
- result is a data buffer (kind 8), a named set is symbol+boff, and a field
|
|
|
- reached through DI is already addressed. *)
|
|
|
-BEGIN
|
|
|
- IF r.kind = 5 THEN
|
|
|
- EmPushDi ()
|
|
|
- ELSIF r.kind = 1 THEN
|
|
|
- EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
|
|
|
- ELSIF (r.kind = 7) OR (r.kind = 8) THEN
|
|
|
- EmPushVarAddr (FALSE, r.setoff)
|
|
|
- ELSE
|
|
|
- Err (ENoLib)
|
|
|
- END
|
|
|
-END EmPushSetAddr ;
|
|
|
-
|
|
|
-PROCEDURE SetPairSize (left, right : ERes ; VAR size, base : CARDINAL) : BOOLEAN ;
|
|
|
-(* The byte count for a set operation. An inline literal is a 32-byte
|
|
|
- `set of Char' by default; when the other operand is a typed set (CALC's
|
|
|
- one-byte `set of Attributes') that type wins. Two non-literals must have
|
|
|
- the same origin and are taken at the smaller size; the runtime only ever
|
|
|
- touches that many bytes. *)
|
|
|
-BEGIN
|
|
|
- IF left.setbase # right.setbase THEN
|
|
|
- RETURN FALSE
|
|
|
- END ;
|
|
|
- base := left.setbase ;
|
|
|
- IF left.kind = 7 THEN
|
|
|
- IF right.kind = 7 THEN
|
|
|
- size := left.setsize
|
|
|
- ELSE
|
|
|
- size := right.setsize
|
|
|
- END
|
|
|
- ELSIF right.kind = 7 THEN
|
|
|
- size := left.setsize
|
|
|
- ELSE
|
|
|
- size := left.setsize ;
|
|
|
- IF right.setsize < size THEN
|
|
|
- size := right.setsize
|
|
|
- END
|
|
|
- END ;
|
|
|
- RETURN (size > 0) AND (size <= 32)
|
|
|
-END SetPairSize ;
|
|
|
-
|
|
|
-PROCEDURE AllocSetScratch (size : CARDINAL) : CARDINAL ;
|
|
|
-(* A fresh data buffer for one set expression. One per operation, so a nested
|
|
|
- or repeated expression cannot overwrite the other side while it is still
|
|
|
- being consumed. The bytes need no initialisation: every operation writes
|
|
|
- all `size' of them before the value is read. *)
|
|
|
-VAR off : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- IF dc + size > 0F000H THEN
|
|
|
- Err (EConstRange) ;
|
|
|
- RETURN 0
|
|
|
- END ;
|
|
|
- off := dc ;
|
|
|
- dc := dc + size ;
|
|
|
- RETURN off
|
|
|
-END AllocSetScratch ;
|
|
|
-
|
|
|
-PROCEDURE SetBinEmit (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ;
|
|
|
-(* The caller has already pushed the LEFT address (before parsing the right
|
|
|
- operand, so a DI-addressed field survives). Finish the argument list -
|
|
|
- right, destination, (op<<8)|size - call the runtime, and return the buffer
|
|
|
- as a kind-8 set value. *)
|
|
|
-VAR size, base, dest : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- IF NOT SetPairSize (left, right, size, base) THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- dest := AllocSetScratch (size) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- EmPushSetAddr (right) ;
|
|
|
- EmPushVarAddr (FALSE, dest) ;
|
|
|
- EmMovAxi (W16 (op * 256 + size)) ;
|
|
|
- EmPushAx () ;
|
|
|
- DropC (EmCall (TU_SetOp)) ;
|
|
|
- EmAddSp (8) ;
|
|
|
- res.kind := 8 ;
|
|
|
- res.cls := TSet ;
|
|
|
- res.chr := FALSE ;
|
|
|
- res.setoff := dest ;
|
|
|
- res.setbase := base ;
|
|
|
- res.setsize := size
|
|
|
-END SetBinEmit ;
|
|
|
-
|
|
|
-PROCEDURE MaterializeDyn (VAR r : ERes ; base, size : CARDINAL) ;
|
|
|
-(* Build a scratch set of `size' bytes with the single dynamic element at
|
|
|
- `base' set. Used for TP3's `[Storage[Index]]' constructor. *)
|
|
|
-VAR dest : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- dest := AllocSetScratch (size) ;
|
|
|
- IF NOT OK () THEN
|
|
|
+ EmMovCxi (VarSize (r)) ;
|
|
|
+ DropC (EmCall (TU_MemCopy)) ;
|
|
|
+ EmAddSp (4) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- EmMovAxi (size) ; EmPushAx () ;
|
|
|
- EmMovAxi (base) ; EmPushAx () ;
|
|
|
- LoadSymVar (r.dynElem, symtab [r.dynElem].off, 2) ;
|
|
|
- EmPushAx () ;
|
|
|
- EmPushVarAddr (FALSE, dest) ;
|
|
|
- DropC (EmCall (TU_SetSingle)) ;
|
|
|
- EmAddSp (8) ;
|
|
|
- r.kind := 8 ;
|
|
|
- r.setoff := dest ;
|
|
|
- r.setbase := base ;
|
|
|
- r.setsize := size
|
|
|
-END MaterializeDyn ;
|
|
|
-
|
|
|
-PROCEDURE EmPushStrAddr (r : ERes) ;
|
|
|
-(* Push the ADDRESS of a whole-string operand - the argument shape cmpstr
|
|
|
- takes, one per operand.
|
|
|
-
|
|
|
- A string VARIABLE's value already is its address, so this is the same push
|
|
|
- READ makes (EmPushVarAddr), through symtab's local/off.
|
|
|
-
|
|
|
- A string LITERAL has no storage, and the image carries no initialised data
|
|
|
- to put one in (globals are left to the loader's zero fill), so the
|
|
|
- characters have to travel in the code stream and the operand is the address
|
|
|
- of those bytes. TP3 does the same in TPSRC9 fullvar (993): it builds the
|
|
|
- `JMP' opcode in AL and the length in AH (`MOV AL,#$EB' / `MOV.B AH,CH'),
|
|
|
- emits that word, and takes the position immediately after it as varofs,
|
|
|
- with varseg := CS - the instruction stream steps over the constant instead
|
|
|
- of running into it.
|
|
|
-
|
|
|
- The difference is one byte, and it is deliberate. TP3's constant is an
|
|
|
- ARRAY [1..n] OF CHAR, and `estr2' (TPSRC10 85) emits it WITHOUT a length
|
|
|
- byte because the length travelled on the stack instead. Every string in
|
|
|
- THIS runtime - variable or literal - is a `string': a length byte and then
|
|
|
- the characters, which is what rdstr writes and what cmpstr reads. So a
|
|
|
- literal operand has to look the same, and the jump carries one extra byte:
|
|
|
- <len><chars>, with the ADDRESS pushed being the length byte itself. The
|
|
|
- jump still exists only to keep the CPU from walking into the characters.
|
|
|
-
|
|
|
- Nothing is added to the data segment and no runtime entry is involved in
|
|
|
- reading the literal; LEA AX,[that] is absolute into the code segment, which
|
|
|
- is where a .COM's DS already is.
|
|
|
-
|
|
|
- A 1-character literal is NOT a TString here: RdConst reports it as TScalar
|
|
|
- (its character code), so `s = 'a'` compares a string with a character and
|
|
|
- is a type error rather than a length-1 string compare. That is deliberate
|
|
|
- - it is the same rule `c := 'a'` relies on - and the caller rejects it. *)
|
|
|
-BEGIN
|
|
|
- IF r.kind = 5 THEN
|
|
|
- (* a string element/field computed through DI - `Sheet[X,Y].Contents'
|
|
|
- and the `with' form. DI holds the field's address, which is exactly
|
|
|
- what cmpstr/strcat/strstore take on the stack, so push it. This used
|
|
|
- to be ENoLib, and it was the CALC rung after Write(Value:FW:DEC):
|
|
|
- `if Sheet[UFX,UFY].Contents <> '' then'. *)
|
|
|
- EmPushDi ()
|
|
|
- ELSIF r.kind = 1 THEN
|
|
|
- IF symtab [r.idx].isVar THEN
|
|
|
- (* A VAR string parameter: the slot at [BP+off] holds the address of
|
|
|
- the caller's characters, so push its CONTENTS, not the address of
|
|
|
- the slot. boff is zero for the whole string; an element/subscript
|
|
|
- is kind 5 and handled above. *)
|
|
|
- IF r.boff # 0 THEN
|
|
|
- Err (ENoLib)
|
|
|
- ELSE
|
|
|
- LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
|
|
|
- EmPushAx ()
|
|
|
- END
|
|
|
- ELSE
|
|
|
- EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
|
|
|
- END
|
|
|
- ELSIF r.kind = 3 THEN
|
|
|
- EmPushVarAddr (FALSE, EmStrBlob (r)) (* the literal travels inline *)
|
|
|
- ELSE
|
|
|
- Err (ENoLib) (* a computed string is not a value *)
|
|
|
- END
|
|
|
-END EmPushStrAddr ;
|
|
|
-
|
|
|
-PROCEDURE EmPushRealAddr (r : ERes) ;
|
|
|
-(* Push the address of a six-byte REAL actual: ordinary variable, VAR REAL
|
|
|
- parameter (slot holds the address), or a kind-5 field/function result. *)
|
|
|
-BEGIN
|
|
|
- IF r.kind = 5 THEN
|
|
|
- EmPushDi ()
|
|
|
- ELSIF r.kind = 1 THEN
|
|
|
- IF symtab [r.idx].isVar THEN
|
|
|
- LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
|
|
|
- EmPushAx ()
|
|
|
- ELSE
|
|
|
- EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
|
|
|
- END
|
|
|
- ELSE
|
|
|
- Err (ENoLib)
|
|
|
- END
|
|
|
-END EmPushRealAddr ;
|
|
|
-
|
|
|
-PROCEDURE EmPushRealSlot (r : ERes ; reserve : CARDINAL) ;
|
|
|
-(* Push a six-byte value REAL argument's whole slot onto the stack. *)
|
|
|
-BEGIN
|
|
|
- EmPushRealAddr (r) ;
|
|
|
- EmPopSi () ;
|
|
|
- EmSubSp (reserve) ;
|
|
|
- Ebyte (89H) ; Ebyte (0E7H) ; (* MOV DI,SP *)
|
|
|
- EmMovCxi (reserve) ;
|
|
|
- Ebyte (8AH) ; Ebyte (04H) ; (* MOV AL,[SI] *)
|
|
|
- Ebyte (88H) ; Ebyte (05H) ; (* MOV [DI],AL *)
|
|
|
- Ebyte (46H) ; Ebyte (47H) ; (* INC SI / INC DI *)
|
|
|
- Ebyte (0E2H) ; Ebyte (0F8H) (* LOOP back *)
|
|
|
-END EmPushRealSlot ;
|
|
|
-
|
|
|
-PROCEDURE EmCopyRealTo (dstOff : CARDINAL ; r : ERes) ;
|
|
|
-(* Copy six REAL bytes from r's address into the image global at dstOff, or
|
|
|
- materialise an integer constant there as MBF. *)
|
|
|
-VAR k : CARDINAL ;
|
|
|
- rbuf : ARRAY [0..5] OF CHAR ;
|
|
|
-BEGIN
|
|
|
IF r.cls = TReal THEN
|
|
|
- EmPushRealAddr (r) ;
|
|
|
- EmPopSi () ;
|
|
|
- EmLeaDi (FALSE, dstOff) ;
|
|
|
- EmMovCxi (6) ;
|
|
|
- Ebyte (8AH) ; Ebyte (04H) ; (* MOV AL,[SI] *)
|
|
|
- Ebyte (88H) ; Ebyte (05H) ; (* MOV [DI],AL *)
|
|
|
- Ebyte (46H) ; Ebyte (47H) ;
|
|
|
- Ebyte (0E2H) ; Ebyte (0F8H) (* LOOP -8 *)
|
|
|
- ELSIF (r.cls = TScalar) AND (r.kind = 0) THEN
|
|
|
- IntToMbf (r.imm, rbuf) ;
|
|
|
- k := 0 ;
|
|
|
- WHILE k < 6 DO
|
|
|
- EmMovAxi (ORD (rbuf [k])) ;
|
|
|
- EmStoreVar (FALSE, (dstOff + k) MOD 10000H, 1) ;
|
|
|
- INC (k)
|
|
|
- END
|
|
|
- ELSE
|
|
|
- Err (ENoLib)
|
|
|
- END
|
|
|
-END EmCopyRealTo ;
|
|
|
-
|
|
|
-PROCEDURE EmPushStrSlot (r : ERes ; reserve, copyN : CARDINAL) ;
|
|
|
-(* Push a STRING VALUE argument's whole slot: reserve `reserve' bytes on the
|
|
|
- stack and copy `copyN' of the source string's <len><chars> into them, so
|
|
|
- that after the CALL the callee's BP+4 is the length byte and the characters
|
|
|
- follow it.
|
|
|
-
|
|
|
- <push the source address, then POP SI> ; local/global/literal alike
|
|
|
- SUB SP,reserve ; MOV DI,SP ; MOV CX,copyN
|
|
|
- loop: MOV AL,[SI] ; MOV [DI],AL ; INC SI ; INC DI ; LOOP loop
|
|
|
-
|
|
|
- The address comes from EmPushStrAddr, which already knows how to form it for
|
|
|
- a local ([BP+off]), a global (absolute) or a literal (inline blob) - so a
|
|
|
- caller's LOCAL string can be passed too, not just a global.
|
|
|
-
|
|
|
- A byte loop, not REP MOVSB, on purpose: MOVS/STOS address through ES, and a
|
|
|
- .COM's ES happens to equal DS but nothing in this compiler establishes that
|
|
|
- contract. Every access here is DS-relative, which is the one segment the
|
|
|
- image already guarantees. `copyN' is at most `reserve' (a shorter actual
|
|
|
- string than the formal leaves the tail of the slot untouched, harmless
|
|
|
- because the length byte bounds every read). *)
|
|
|
-BEGIN
|
|
|
- EmPushStrAddr (r) ; (* push the source address *)
|
|
|
- EmPopSi () ; (* SI := source *)
|
|
|
- EmSubSp (reserve) ;
|
|
|
- Ebyte (89H) ; Ebyte (0E7H) ; (* MOV DI,SP *)
|
|
|
- EmMovCxi (copyN) ;
|
|
|
- IF copyN > 0 THEN
|
|
|
- Ebyte (8AH) ; Ebyte (04H) ; (* MOV AL,[SI] *)
|
|
|
- Ebyte (88H) ; Ebyte (05H) ; (* MOV [DI],AL *)
|
|
|
- Ebyte (46H) ; (* INC SI *)
|
|
|
- Ebyte (47H) ; (* INC DI *)
|
|
|
- Ebyte (0E2H) ; Ebyte (0F8H) (* LOOP -8: back to MOV AL,[SI] *)
|
|
|
- END
|
|
|
-END EmPushStrSlot ;
|
|
|
-
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-(* sets - type sizing, literals, compile-time membership *)
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-
|
|
|
-PROCEDURE SetRangeBits (VAR bytes : ARRAY OF CHAR ; size, base : CARDINAL ;
|
|
|
- lo, hi : LONGINT) ;
|
|
|
-(* Set the bits for every element in [lo, hi], using TP3's hybrid rule
|
|
|
- (coeur-tp-ocr 4.7.2): element e is bit (e MOD 8) of byte
|
|
|
- ((e DIV 8) - (base DIV 8)), and is IGNORED unless that byte is in
|
|
|
- [0, size). A value that lands outside the used bytes is truncated away, as
|
|
|
- TP3 does; one inside them but outside the DECLARED range still lands, which
|
|
|
- is also TP3's behaviour. *)
|
|
|
-VAR rel, first, last, bidx, bit, m, o : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- IF (hi < 0) OR (lo > 255) THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF lo < 0 THEN first := 0 ELSE first := VAL (CARDINAL, lo) END ;
|
|
|
- IF hi > 255 THEN last := 255 ELSE last := VAL (CARDINAL, hi) END ;
|
|
|
- rel := first ;
|
|
|
- WHILE rel <= last DO
|
|
|
- IF rel >= base THEN
|
|
|
- bidx := (rel - base) DIV 8 ;
|
|
|
- IF bidx < size THEN
|
|
|
- bit := (rel - base) MOD 8 ;
|
|
|
- m := 1 ;
|
|
|
- WHILE bit > 0 DO
|
|
|
- m := m * 2 ; DEC (bit)
|
|
|
+ (* 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 ;
|
|
|
- o := ORD (bytes [bidx]) ;
|
|
|
- IF (o DIV m) MOD 2 = 0 THEN
|
|
|
- bytes [bidx] := CHR (o + m)
|
|
|
- END
|
|
|
- END
|
|
|
- END ;
|
|
|
- INC (rel)
|
|
|
- END
|
|
|
-END SetRangeBits ;
|
|
|
-
|
|
|
-PROCEDURE RdSetLiteral (base, size : CARDINAL ; VAR bytes : ARRAY OF CHAR) : BOOLEAN ;
|
|
|
-(* Read a set constructor `[e, a..b, ...]' and fill `bytes' (already size
|
|
|
- long). `[]' is the empty set. *)
|
|
|
-VAR v, hi : LONGINT ; subcls : CARDINAL ; strf : BOOLEAN ; k : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- k := 0 ;
|
|
|
- WHILE k < size DO
|
|
|
- bytes [k] := CHR (0) ;
|
|
|
- INC (k)
|
|
|
- END ;
|
|
|
- ExpectDelim ('[', ENoSemi) ;
|
|
|
- IF MatchDelim (']') THEN
|
|
|
- RETURN OK () (* [] - the empty set *)
|
|
|
- END ;
|
|
|
- LOOP
|
|
|
- RdConst (v, subcls, strf) ;
|
|
|
- IF strf THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN FALSE
|
|
|
- END ;
|
|
|
- IF MatchRange () THEN
|
|
|
- RdConst (hi, subcls, strf) ;
|
|
|
- IF strf THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN FALSE
|
|
|
- END
|
|
|
- ELSE
|
|
|
- hi := v
|
|
|
- END ;
|
|
|
- SetRangeBits (bytes, size, base, v, hi) ;
|
|
|
- IF MatchDelim (',') THEN
|
|
|
- (* another element *)
|
|
|
- ELSE
|
|
|
- EXIT
|
|
|
- END
|
|
|
- END ;
|
|
|
- ExpectDelim (']', ENoSemi) ;
|
|
|
- RETURN OK ()
|
|
|
-END RdSetLiteral ;
|
|
|
-
|
|
|
-PROCEDURE EmSetBlob (VAR bytes : ARRAY OF CHAR ; size : CARDINAL) : CARDINAL ;
|
|
|
-(* Emit a set's bytes into the code stream behind a JMP over them - the same
|
|
|
- trick EmPushStrAddr uses for a string literal - and return the image offset
|
|
|
- of the first byte. Nothing goes in the data segment: a .COM's DS already
|
|
|
- covers the code segment, which is why this port needs no `seg cs' where the
|
|
|
- original did (see CALC-COMPILE.md's typed-constant storage decision). *)
|
|
|
-VAR here, k : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- IF size + 2 <= 127 THEN
|
|
|
- Ebyte (0EBH) ; Ebyte (VAL (BYTE, size)) (* JMP rel8 over it *)
|
|
|
- ELSE
|
|
|
- Ebyte (0E9H) ; Eword (size) (* JMP rel16 over it *)
|
|
|
- END ;
|
|
|
- here := pc ;
|
|
|
- k := 0 ;
|
|
|
- WHILE k < size DO
|
|
|
- Ebyte (VAL (BYTE, ORD (bytes [k]))) ;
|
|
|
- INC (k)
|
|
|
- END ;
|
|
|
- RETURN here
|
|
|
-END EmSetBlob ;
|
|
|
-
|
|
|
-PROCEDURE FoldSetIn (left, right : ERes ; VAR res : ERes) ;
|
|
|
-(* `e IN s' where e is a compile-time ordinal and s a set whose bytes are
|
|
|
- already in the image: answer at compile time, exactly as TPSRC2's xsetin
|
|
|
- answers at run time (AH > 255 -> FALSE, else test the bit). A run-time
|
|
|
- element or a run-time set is still ENoLib - that is the next milestone, and
|
|
|
- it must stay LOUD rather than silently answer wrong. *)
|
|
|
-VAR off, base, size, rel, bidx, bit, m, o : CARDINAL ;
|
|
|
- isIn, foldable : BOOLEAN ;
|
|
|
- jl, jg, jmp : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- res.kind := 0 ;
|
|
|
- res.imm := 0 ;
|
|
|
- res.cls := TBool ;
|
|
|
- res.chr := FALSE ;
|
|
|
- IF right.cls # TSet THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF left.kind # 0 THEN
|
|
|
- (* A RUN-TIME element (`Upcase(Ch) in ['Y','N']', `Ch in ['a'..'z']').
|
|
|
- Materialise it in AX, subtract the set's base, reject the out-of-range
|
|
|
- values with the two signed tests the compiler declares (L and G), then
|
|
|
- index the bit array: byte = (e-base) DIV 8, bit = (e-base) MOD 8.
|
|
|
- The set's address is formed according to where its bytes live: an
|
|
|
- inline literal or typed constant is code-resident (image offset +
|
|
|
- LoadBias), a data set is an absolute or BP-relative address. A set
|
|
|
- already addressed through DI and an element that itself needs DI are
|
|
|
- refused: the address would be lost. *)
|
|
|
- IF right.kind = 5 THEN
|
|
|
+ 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 ;
|
|
|
- LoadAtom (left) ;
|
|
|
+ IF r.kind = 5 THEN
|
|
|
+ EmPushDi ()
|
|
|
+ END ;
|
|
|
+ ParseExpr (src) ;
|
|
|
IF NOT OK () THEN
|
|
|
RETURN
|
|
|
END ;
|
|
|
- IF right.setbase # 0 THEN
|
|
|
- EmMovCxi (W16 (right.setbase)) ;
|
|
|
- EmSubAxCx ()
|
|
|
+ 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 ;
|
|
|
- EmCmpAxi (0) ;
|
|
|
- jl := EmJcc (8CH, 0) ; (* JL -> false *)
|
|
|
- EmCmpAxi (W16 (right.setsize * 8)) ;
|
|
|
- jg := EmJcc (8FH, 0) ; (* JG -> false *)
|
|
|
- EmMovClAl () ;
|
|
|
- EmAndClImm (7) ;
|
|
|
- EmShrAx1 () ; EmShrAx1 () ; EmShrAx1 () ; (* AX := byte index *)
|
|
|
- IF right.kind = 7 THEN
|
|
|
- EmMovBxi (W16 (right.setoff + LoadBias))
|
|
|
- ELSIF right.kind = 1 THEN
|
|
|
- IF symtab [right.idx].local THEN
|
|
|
- EmLeaBx ((right.setoff + right.boff) MOD 10000H)
|
|
|
- ELSE
|
|
|
- EmMovBxi ((right.setoff + right.boff + LoadBias) MOD 10000H)
|
|
|
- END
|
|
|
- ELSE
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- EmAddBxAx () ; (* BX := the set's byte *)
|
|
|
- EmLdAlBx () ;
|
|
|
- EmMovDlImm (1) ;
|
|
|
- EmShlDlCl () ; (* DL := 1 << bit *)
|
|
|
- EmAndAlDl () ;
|
|
|
- EmMovAh0 () ;
|
|
|
- EmOrAxAx () ;
|
|
|
- EmRelSetcc (2) ; (* SETNE: the bit was set *)
|
|
|
- jmp := EmJmpNear (0) ;
|
|
|
- SetPatTgt (jl, pc) ;
|
|
|
- SetPatTgt (jg, pc) ;
|
|
|
- EmMovAxi (0) ;
|
|
|
- SetPatTgt (jmp, pc) ;
|
|
|
- res.kind := 2 ;
|
|
|
- res.cls := TBool ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- (* A code-resident set (an inline literal or a typed constant) folds at
|
|
|
- compile time. A DATA set - a record field, local or global, or one
|
|
|
- addressed through DI - must be tested at run time: its byte is in the
|
|
|
- image's data area, not in cbuf. A typed constant's offset is below
|
|
|
- dataBase; a global's is at or above it. *)
|
|
|
- foldable := (right.kind = 7) ;
|
|
|
- IF (right.kind = 1) AND NOT symtab [right.idx].local
|
|
|
- AND (right.setoff + right.boff < dataBase) THEN
|
|
|
- foldable := TRUE
|
|
|
- END ;
|
|
|
- IF NOT foldable THEN
|
|
|
- IF (left.imm >= 0) AND (left.imm <= 255) THEN
|
|
|
- base := right.setbase ; size := right.setsize ;
|
|
|
- rel := VAL (CARDINAL, left.imm) ;
|
|
|
- IF rel >= base THEN
|
|
|
- bidx := (rel - base) DIV 8 ;
|
|
|
- IF bidx < size THEN
|
|
|
- bit := (rel - base) MOD 8 ;
|
|
|
- m := 1 ;
|
|
|
- WHILE bit > 0 DO
|
|
|
- m := m * 2 ; DEC (bit)
|
|
|
- END ;
|
|
|
- IF right.kind = 5 THEN
|
|
|
- EmLdAlDiOff (bidx)
|
|
|
- ELSIF right.kind = 1 THEN
|
|
|
- LoadSymVar (right.idx, (right.setoff + right.boff + bidx) MOD 10000H, 1)
|
|
|
- ELSE
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- EmAndAlImm (m) ;
|
|
|
- EmMovAh0 () ;
|
|
|
- EmOrAxAx () ;
|
|
|
- EmRelSetcc (2) ; (* SETNE: the bit was set *)
|
|
|
- res.kind := 2 ;
|
|
|
- res.cls := TBool ;
|
|
|
- RETURN
|
|
|
+ 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
|
|
|
- END
|
|
|
- END ;
|
|
|
- res.imm := 0 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- isIn := FALSE ;
|
|
|
- IF (left.imm >= 0) AND (left.imm <= 255) THEN
|
|
|
- off := right.setoff ; base := right.setbase ; size := right.setsize ;
|
|
|
- rel := VAL (CARDINAL, left.imm) ;
|
|
|
- IF rel >= base THEN
|
|
|
- bidx := (rel - base) DIV 8 ;
|
|
|
- IF bidx < size THEN
|
|
|
- bit := (rel - base) MOD 8 ;
|
|
|
- m := 1 ;
|
|
|
- WHILE bit > 0 DO
|
|
|
- m := m * 2 ; DEC (bit)
|
|
|
- END ;
|
|
|
- o := VAL (CARDINAL, cbuf [off + bidx]) ;
|
|
|
- isIn := (o DIV m) MOD 2 # 0
|
|
|
- END
|
|
|
- END
|
|
|
- END ;
|
|
|
- res.imm := ORD (isIn)
|
|
|
-END FoldSetIn ;
|
|
|
-
|
|
|
-PROCEDURE RdSetBase (VAR baseCls : CARDINAL ; VAR lo, hi : LONGINT) ;
|
|
|
-(* The base type of `set of ...': an ordinal range. `Char' and `byte' are
|
|
|
- 0..255; a literal subrange `a..b' is read directly. A named or enumerated
|
|
|
- base is ENoLib for now - `set of Attributes' waits for enums. *)
|
|
|
-VAR idx, subcls : CARDINAL ; strf : BOOLEAN ;
|
|
|
-BEGIN
|
|
|
- baseCls := TScalar ;
|
|
|
- Skip () ;
|
|
|
- IF Alpha (CurCh ()) THEN
|
|
|
- GetWord () ;
|
|
|
- IF Search (wrd, idx) AND (symtab [idx].tag = KType) THEN
|
|
|
- IF symtab [idx].cls = TEnum THEN
|
|
|
- lo := symtab [idx].lo ;
|
|
|
- hi := symtab [idx].hi ;
|
|
|
- baseCls := TEnum
|
|
|
- ELSIF (symtab [idx].cls = TChar)
|
|
|
- OR ((symtab [idx].cls = TScalar) AND (symtab [idx].size = 1)) THEN
|
|
|
- lo := 0 ; hi := 255 ; baseCls := symtab [idx].cls
|
|
|
ELSE
|
|
|
Err (ENoLib)
|
|
|
- END
|
|
|
- ELSE
|
|
|
- Err (EUnknown)
|
|
|
- END
|
|
|
- ELSE
|
|
|
- RdConst (lo, subcls, strf) ;
|
|
|
- IF NOT MatchRange () THEN
|
|
|
- Err (ESimpType) ;
|
|
|
+ END ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- RdConst (hi, subcls, strf) ;
|
|
|
- IF (lo < 0) OR (hi > 255) OR (lo > hi) THEN
|
|
|
- Err (EConstRange)
|
|
|
- END
|
|
|
- END
|
|
|
-END RdSetBase ;
|
|
|
-
|
|
|
-PROCEDURE NewScratchStr () : CARDINAL ;
|
|
|
-(* Allocate a fresh 256-byte global STRING and return its symbol index.
|
|
|
-
|
|
|
- A concatenation result needs STORAGE the emitted code can name. Making the
|
|
|
- result a string VARIABLE (kind 1) is what keeps every downstream consumer
|
|
|
- untouched: Assignment, IoCall and ParseCmp already handle kind 1, so `s :=
|
|
|
- a + b', `writeln(a + b)' and `(a + b) = c' work with no code of their own.
|
|
|
-
|
|
|
- One scratch PER `+' in the source, so a repeated or nested concatenation
|
|
|
- never shares a destination - `a + b + c' is two occurrences and gets two
|
|
|
- scratch strings, and the first result survives until the second consumes it.
|
|
|
- (A loop reuses its site's scratch, which is correct because each execution
|
|
|
- writes before it reads.) Recursion would break that, but this compiler
|
|
|
- compiles no procedures yet - see the item list.
|
|
|
-
|
|
|
- 256 bytes is the STRING type's own size, length byte plus 255 characters:
|
|
|
- see ParseType's TkString arm and the predefined STRING in Inittur. The name
|
|
|
- is a placeholder (nothing looks a scratch up by name) spelled with '@', as
|
|
|
- tmpA/tmpB are, so it cannot collide with a Modula-2 identifier. *)
|
|
|
-BEGIN
|
|
|
- DropC (NewSym ("@@SC", KVar, TString, 256, 1, dc, 0, FALSE)) ;
|
|
|
- dc := dc + 256 ;
|
|
|
- RETURN symTop - 1
|
|
|
-END NewScratchStr ;
|
|
|
-
|
|
|
-PROCEDURE NewScratchWord () : CARDINAL ;
|
|
|
-(* Two bytes for a dynamic set literal's element value. *)
|
|
|
-BEGIN
|
|
|
- DropC (NewSym ("@@DW", KVar, TScalar, 2, 2, dc, 0, FALSE)) ;
|
|
|
- dc := dc + 2 ;
|
|
|
- RETURN symTop - 1
|
|
|
-END NewScratchWord ;
|
|
|
-
|
|
|
-PROCEDURE NewScratchReal () : CARDINAL ;
|
|
|
-(* Six bytes of storage for a REAL function result, one per call site. *)
|
|
|
-BEGIN
|
|
|
- DropC (NewSym ("@@RL", KVar, TReal, 6, 6, dc, 0, FALSE)) ;
|
|
|
- dc := dc + 6 ;
|
|
|
- RETURN symTop - 1
|
|
|
-END NewScratchReal ;
|
|
|
-
|
|
|
-PROCEDURE NewScratchRealBlock () : CARDINAL ;
|
|
|
-(* Twelve bytes for a binary REAL operation: a followed by b. *)
|
|
|
-BEGIN
|
|
|
- DropC (NewSym ("@@RB", KVar, TReal, 12, 6, dc, 0, FALSE)) ;
|
|
|
- dc := dc + 12 ;
|
|
|
- RETURN symTop - 1
|
|
|
-END NewScratchRealBlock ;
|
|
|
-
|
|
|
-PROCEDURE StrOperand (r : ERes) : BOOLEAN ;
|
|
|
-(* Is r usable as one operand of `+'? A STRING, or a CHAR - which can appear
|
|
|
- three ways: a quoted literal (cls TScalar with chr set), a CHAR variable
|
|
|
- (cls TChar), and a string element s[i] (cls TChar, kind 5). A number is
|
|
|
- not, and neither is a BOOLEAN. *)
|
|
|
-BEGIN
|
|
|
- RETURN (r.cls = TString) OR (r.cls = TChar) OR
|
|
|
- ((r.cls = TScalar) AND r.chr)
|
|
|
-END StrOperand ;
|
|
|
-
|
|
|
-PROCEDURE EmPushStrOperand (r : ERes) ;
|
|
|
-(* Push the ADDRESS of one concatenation operand, converting a CHAR to a
|
|
|
- length-1 string first.
|
|
|
-
|
|
|
- A STRING operand is pushed exactly as cmpstr pushes one (EmPushStrAddr):
|
|
|
- a variable's value already IS its address, and a literal travels inline.
|
|
|
-
|
|
|
- A CHAR operand has no such address, so it is materialised as a
|
|
|
- `<length 1><character>' string in a fresh 2-byte scratch and the address of
|
|
|
- THAT is pushed. This is TPSRC9's addch/addch2, which splice a character
|
|
|
- into a concatenation by building a one-character string. The character is
|
|
|
- loaded into AL (LoadAtom), the character is stored at [coff+1] and the
|
|
|
- length 1 at [coff]. At most one operand of a concatenation is a CHAR -
|
|
|
- StrConcat rejects char+char - so at most one such scratch is ever made. *)
|
|
|
-VAR coff : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- IF r.cls = TString THEN
|
|
|
- EmPushStrAddr (r)
|
|
|
- ELSE
|
|
|
- coff := dc ;
|
|
|
- dc := dc + 2 ;
|
|
|
- LoadAtom (r) ; (* AX := the character *)
|
|
|
- EmStoreVar (FALSE, (coff + 1) MOD 10000H, 1) ; (* [coff+1] := AL *)
|
|
|
- EmMovAxi (1) ; (* AX := 1 *)
|
|
|
- EmStoreVar (FALSE, coff MOD 10000H, 1) ; (* [coff] := AL = length *)
|
|
|
- EmPushVarAddr (FALSE, coff MOD 10000H)
|
|
|
- END
|
|
|
-END EmPushStrOperand ;
|
|
|
-
|
|
|
-PROCEDURE StrConcat (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ;
|
|
|
-(* `left + right' for strings: TPSRC2's xconcat, emitted as two runtime calls.
|
|
|
-
|
|
|
- The layout is `<length byte><characters>' and `+' needs a place to build its
|
|
|
- result, so this allocates one 256-byte global scratch (NewScratchStr) and
|
|
|
- copies into it: first `dest := left' through the runtime's strstore, then
|
|
|
- `dest := dest + right' through strcat, which appends. Using strstore for
|
|
|
- the left operand and strcat for the right keeps the append logic in one
|
|
|
- place and gives the compiler exactly one new entry to reach; it also means
|
|
|
- the two calls have the same argument shape (source pushed first, destination
|
|
|
- last, limit in CX), so the emission differs only in the entry named.
|
|
|
-
|
|
|
- The limit is 255 - the scratch's 255 usable characters. An overflowing
|
|
|
- result is a RUNTIME ERROR with exit code 16, TP3's `String too long', not a
|
|
|
- truncation; see Runtime.EmitStrCat.
|
|
|
-
|
|
|
- The operator rule: `+' concatenates, anything else over a STRING is a type
|
|
|
- error, and char+char is ALSO a type error. ISO Modula-2 gives no meaning to
|
|
|
- two characters summed, and inventing one (a two-character string?) would be
|
|
|
- a guess this compiler does not make; TP3's own behaviour there is not
|
|
|
- something the reference pins down. That char+char choice is the one place
|
|
|
- this differs from a literal reading of the reference, and it is recorded
|
|
|
- here and in v-TP3-STRCAT.md rather than left to be discovered.
|
|
|
-
|
|
|
- The guard below is what ENFORCES that rule, and it only runs because
|
|
|
- BinOpEmit's hook routes a CHAR operand here too. A hook that tested for a
|
|
|
- STRING operand only would send `'a' + 'b'' to the integer path instead and
|
|
|
- this test would never be reached - which is exactly what it did until
|
|
|
- t53_strcat_type caught it. Three ways to fail it: a non-`+' operator over
|
|
|
- a string operand, an operand that is neither a string nor a CHAR (a number),
|
|
|
- and two CHARs with no STRING on either side. *)
|
|
|
-VAR dest : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- (* A placeholder for the paths below that bail out through Err. Err only
|
|
|
- records the first error and does not unwind, so the caller goes on to use
|
|
|
- res regardless: after `Err (ETypeErr)' in the guard, ParseAdd hands res
|
|
|
- straight back to IoCall, to Assignment or to an enclosing concatenation.
|
|
|
- The placeholder's SHAPE therefore matters. It must not claim to be a
|
|
|
- STRING, because the string consumers reach symtab[res.idx] for any TString
|
|
|
- (IoCall's `writeln' arm does) and idx is not a symbol here; and it must be
|
|
|
- something LoadAtom can fold, because the numeric consumers will try. The
|
|
|
- integer 0 is both. Leaving kind-2/TString here, as this once did, turned
|
|
|
- `writeln('a' + 'b')' - two CHARs, a type error - into a compiler segfault
|
|
|
- instead of an error message. *)
|
|
|
- res.kind := 0 ;
|
|
|
- res.imm := 0 ;
|
|
|
- res.cls := TScalar ;
|
|
|
- res.boff := 0 ;
|
|
|
- res.chr := FALSE ;
|
|
|
- IF (op # OpAdd) OR NOT StrOperand (left) OR NOT StrOperand (right) OR
|
|
|
- ((left.cls # TString) AND (right.cls # TString)) THEN
|
|
|
- Err (ETypeErr) ; (* a STRING on the wrong operator, a number,
|
|
|
- or two CHARs *)
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- dest := NewScratchStr () ;
|
|
|
- (* dest := left *)
|
|
|
- EmPushStrOperand (left) ;
|
|
|
- EmPushVarAddr (FALSE, (symtab [dest].off) MOD 10000H) ;
|
|
|
- EmMovCxi (255) ;
|
|
|
- DropC (EmCall (TU_StrStore)) ;
|
|
|
- EmAddSp (4) ; (* pop the two addresses strstore took *)
|
|
|
- (* dest := dest + right *)
|
|
|
- EmPushStrOperand (right) ;
|
|
|
- EmPushVarAddr (FALSE, (symtab [dest].off) MOD 10000H) ;
|
|
|
- EmMovCxi (255) ;
|
|
|
- DropC (EmCall (TU_StrCat)) ;
|
|
|
- EmAddSp (4) ;
|
|
|
- res.kind := 1 ;
|
|
|
- res.idx := dest ;
|
|
|
- res.cls := TString ;
|
|
|
- res.boff := 0 ;
|
|
|
- res.chr := FALSE
|
|
|
-END StrConcat ;
|
|
|
-
|
|
|
-PROCEDURE ParseCmp (VAR r : ERes) ;
|
|
|
-(* "=" | "<>" | "<" | "<=" | ">" | ">=" *)
|
|
|
-VAR op : CARDINAL ;
|
|
|
- left, right : ERes ;
|
|
|
- f : LONGINT ;
|
|
|
- size, base, block, scratch : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- ParseAdd (r) ;
|
|
|
- LOOP
|
|
|
- op := 0 ;
|
|
|
- Skip () ;
|
|
|
- IF CurCh () = '=' THEN
|
|
|
- op := 1 ; DropCh (GetCh ())
|
|
|
- ELSIF (CurCh () = '<') AND (PeekAhead (1) = '>') THEN
|
|
|
- op := 2 ; DropCh (GetCh ()) ; DropCh (GetCh ())
|
|
|
- ELSIF CurCh () = '<' THEN
|
|
|
- IF PeekAhead (1) = '=' THEN
|
|
|
- op := 6 ; DropCh (GetCh ()) ; DropCh (GetCh ())
|
|
|
- ELSE
|
|
|
- op := 3 ; DropCh (GetCh ())
|
|
|
- END
|
|
|
- ELSIF CurCh () = '>' THEN
|
|
|
- IF PeekAhead (1) = '=' THEN
|
|
|
- op := 5 ; DropCh (GetCh ()) ; DropCh (GetCh ())
|
|
|
- ELSE
|
|
|
- op := 4 ; DropCh (GetCh ())
|
|
|
- END
|
|
|
- END ;
|
|
|
- IF op = 0 THEN
|
|
|
- IF KwAhead ("IN") THEN
|
|
|
- (* `e IN s' is at the comparison level in TP3 (TPSRC9 cmpin, 116).
|
|
|
- Only the compile-time case is implemented; see FoldSetIn. *)
|
|
|
- GetWord () ;
|
|
|
- left := r ;
|
|
|
- ParseAdd (right) ;
|
|
|
- FoldSetIn (left, right, r) ;
|
|
|
- RETURN
|
|
|
+ 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 ;
|
|
|
- left := r ;
|
|
|
- IF left.cls = TSet THEN
|
|
|
- (* Set comparison. set_cmp returns a mask (bit 0 equal, bit 1 strict
|
|
|
- subset, bit 2 strict superset); the operator selects which bits
|
|
|
- answer it, and the shared EmRelSetcc arm turns the flags into a
|
|
|
- boolean. The left address is pushed before the right operand is
|
|
|
- parsed, for the same DI reason as strings and set arithmetic. *)
|
|
|
- EmPushSetAddr (left) ;
|
|
|
- ParseAdd (right) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF right.cls # TSet THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF NOT SetPairSize (left, right, size, base) THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- EmPushSetAddr (right) ;
|
|
|
- EmMovAxi (size) ;
|
|
|
- EmPushAx () ;
|
|
|
- DropC (EmCall (TU_SetCmp)) ;
|
|
|
- EmAddSp (4) ;
|
|
|
- CASE op OF
|
|
|
- 1 : EmMovCxi (1) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ;
|
|
|
- | 2 : EmMovCxi (1) ; EmAndAxCx () ; EmXorAl01 () ;
|
|
|
- EmOrAxAx () ; EmRelSetcc (2) ;
|
|
|
- | 3 : EmMovCxi (2) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ;
|
|
|
- | 4 : EmMovCxi (4) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ;
|
|
|
- | 5 : EmMovCxi (5) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2) ;
|
|
|
- | 6 : EmMovCxi (3) ; EmAndAxCx () ; EmOrAxAx () ; EmRelSetcc (2)
|
|
|
- END ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TBool
|
|
|
- ELSIF left.cls = TString THEN
|
|
|
- (* A string comparison: cmpstr, the entry TPSRC9's vcompare (133)
|
|
|
- reaches through TPSRC2's csteq/cstne/cstge/cstle/cstg/cstl
|
|
|
- wrappers (890-925).
|
|
|
-
|
|
|
- The operands are pushed as ADDRESSES, before the right-hand parse
|
|
|
- can clobber DI. This is why the left is pushed here rather than
|
|
|
- through SaveLeft: a kind-5 left is a string FIELD whose address is
|
|
|
- in DI, and SaveLeft's job is to materialise a scalar in AX, which
|
|
|
- would read the length byte as a number (or, for a whole string,
|
|
|
- refuse it). `if Sheet[UFX,UFY].Contents <> '' then' was exactly
|
|
|
- that: the CALC rung after Write(Value:FW:DEC).
|
|
|
-
|
|
|
- cmpstr returns AX = -1/0/+1 (see Runtime.mod for why a value and
|
|
|
- not flags), so the second half is exactly the numeric arm's: put
|
|
|
- the sign in the flags and let the shared six-arm table answer.
|
|
|
- EmOrAxAx is OR AX,AX rather than EmCmpAxi(0) on purpose: tests/
|
|
|
- check_8086.py reads every `CMP AX,0000' in the program region as
|
|
|
- an IF/WHILE/REPEAT test and requires a branch right after it, and
|
|
|
- a comparison used as a VALUE (writeln(a = b)) is not one. *)
|
|
|
- EmPushStrAddr (left) ;
|
|
|
- ParseAdd (right) ;
|
|
|
- IF (right.cls = TChar) OR ((right.cls = TScalar) AND right.chr) THEN
|
|
|
- (* `S <> Chr($FF)' / `S <> 'x'': a CHAR is a one-character string.
|
|
|
- Materialise it as a counted scratch so cmpstr sees the same
|
|
|
- layout as every other string operand. *)
|
|
|
- scratch := NewScratchStr () ;
|
|
|
- IF right.kind = 0 THEN
|
|
|
- EmMovAxi (W16 (right.imm)) ;
|
|
|
- EmStoreVar (FALSE, (symtab [scratch].off + 1) MOD 10000H, 1) ;
|
|
|
- EmMovAxi (1) ;
|
|
|
- EmStoreVar (FALSE, symtab [scratch].off, 1)
|
|
|
- ELSE
|
|
|
- LoadAtom (right) ;
|
|
|
- EmStoreVar (FALSE, (symtab [scratch].off + 1) MOD 10000H, 1) ;
|
|
|
- EmMovAxi (1) ;
|
|
|
- EmStoreVar (FALSE, symtab [scratch].off, 1)
|
|
|
- END ;
|
|
|
- right.kind := 1 ; right.idx := scratch ; right.cls := TString ;
|
|
|
- right.sz := 256 ; right.boff := 0
|
|
|
- END ;
|
|
|
- IF right.cls # TString THEN
|
|
|
- Err (ETypeErr) ; (* a string compared with a number *)
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- EmPushStrAddr (right) ;
|
|
|
- DropC (EmCall (TU_CmpStr)) ;
|
|
|
- EmAddSp (4) ;
|
|
|
- EmOrAxAx () ;
|
|
|
- EmRelSetcc (op) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TBool
|
|
|
- ELSIF left.cls = TReal THEN
|
|
|
- (* REAL comparison: recmp takes one 12-byte block holding a then b.
|
|
|
- SaveLeft parks the left address; the right is copied first when it
|
|
|
- is DI-addressed, before the block copy clobbers DI. *)
|
|
|
- SaveLeft (left) ;
|
|
|
- ParseAdd (right) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF (right.cls = TScalar) AND (right.kind = 0) THEN
|
|
|
- scratch := NewScratchReal () ;
|
|
|
- EmCopyRealTo (symtab [scratch].off, right) ;
|
|
|
- right.idx := scratch ; right.kind := 1 ; right.cls := TReal ;
|
|
|
- right.sz := 6 ; right.boff := 0
|
|
|
- END ;
|
|
|
- IF right.cls # TReal THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- block := NewScratchRealBlock () ;
|
|
|
- IF right.kind = 5 THEN
|
|
|
- EmCopyRealTo (symtab [block].off + 6, right) ;
|
|
|
- EmCopyRealTo (symtab [block].off, left)
|
|
|
- ELSE
|
|
|
- EmCopyRealTo (symtab [block].off, left) ;
|
|
|
- EmCopyRealTo (symtab [block].off + 6, right)
|
|
|
- END ;
|
|
|
- EmPushVarAddr (FALSE, symtab [block].off) ;
|
|
|
- DropC (EmCall (TU_RealCmp)) ;
|
|
|
- EmAddSp (2) ;
|
|
|
- EmOrAxAx () ;
|
|
|
- EmRelSetcc (op) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TBool
|
|
|
- ELSE
|
|
|
- SaveLeft (left) ;
|
|
|
- ParseAdd (right) ;
|
|
|
- IF (right.cls = TString) OR (right.cls = TSet) THEN
|
|
|
- Err (ETypeErr) ; (* a number compared with a string/set *)
|
|
|
- RETURN
|
|
|
+ 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 ;
|
|
|
- IF (left.kind = 0) AND (right.kind = 0) THEN
|
|
|
- IF ConstCmp (op, left.imm, right.imm, f) THEN
|
|
|
- r.kind := 0 ;
|
|
|
- r.imm := f ;
|
|
|
- r.cls := TBool
|
|
|
- ELSE
|
|
|
- r.kind := 0 ;
|
|
|
- r.imm := 0 ;
|
|
|
- r.cls := TBool
|
|
|
- END
|
|
|
- ELSE
|
|
|
- LoadPair (left, right) ;
|
|
|
- EmCmpAxCx () ;
|
|
|
- EmRelSetcc (op) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TBool
|
|
|
- END
|
|
|
- END
|
|
|
- END
|
|
|
-END ParseCmp ;
|
|
|
-
|
|
|
-PROCEDURE ParseAdd (VAR r : ERes) ;
|
|
|
-VAR op : CARDINAL ;
|
|
|
- left, right : ERes ;
|
|
|
-BEGIN
|
|
|
- ParseMul (r) ;
|
|
|
- LOOP
|
|
|
- op := 0 ;
|
|
|
- Skip () ;
|
|
|
- IF CurCh () = '+' THEN
|
|
|
- op := OpAdd ; DropCh (GetCh ())
|
|
|
- ELSIF CurCh () = '-' THEN
|
|
|
- op := OpSub ; DropCh (GetCh ())
|
|
|
- ELSIF KwAhead ("OR") THEN
|
|
|
- GetWord () ;
|
|
|
- op := TkOr
|
|
|
- ELSE
|
|
|
RETURN
|
|
|
END ;
|
|
|
- left := r ;
|
|
|
- IF left.cls = TSet THEN
|
|
|
- (* Set union/difference. The left address goes on the stack BEFORE
|
|
|
- the right is parsed: a DI-addressed set field must survive the
|
|
|
- right-hand expression. `OR' is boolean, not set union. *)
|
|
|
- IF (op = OpAdd) OR (op = OpSub) THEN
|
|
|
- EmPushSetAddr (left) ;
|
|
|
- ParseMul (right) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF right.cls # TSet THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
+ IF (src.kind = 1) AND (src.cls = TReal) THEN
|
|
|
+ IF r.kind = 5 THEN
|
|
|
+ IF src.kind = 5 THEN
|
|
|
+ Err (ENoLib) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- IF right.kind = 9 THEN
|
|
|
- MaterializeDyn (right, left.setbase, left.setsize)
|
|
|
- END ;
|
|
|
- IF op = OpAdd THEN
|
|
|
- SetBinEmit (1, left, right, r)
|
|
|
- ELSE
|
|
|
- SetBinEmit (2, left, right, r)
|
|
|
+ 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 (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- ELSE
|
|
|
- SaveLeft (left) ;
|
|
|
- ParseMul (right) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF right.cls = TSet THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
+ Err (ENoLib)
|
|
|
END ;
|
|
|
- BinOpEmit (op, left, right, r)
|
|
|
- END
|
|
|
- END
|
|
|
-END ParseAdd ;
|
|
|
-
|
|
|
-PROCEDURE ParseMul (VAR r : ERes) ;
|
|
|
-VAR op : CARDINAL ;
|
|
|
- left, right : ERes ;
|
|
|
-BEGIN
|
|
|
- ParseNeg (r) ;
|
|
|
- LOOP
|
|
|
- op := 0 ;
|
|
|
- Skip () ;
|
|
|
- IF CurCh () = '*' THEN
|
|
|
- op := OpMul ; DropCh (GetCh ()) (* OpAdd here meant a*b -> a+b *)
|
|
|
- ELSIF CurCh () = '/' THEN
|
|
|
- op := OpDiv ; DropCh (GetCh ())
|
|
|
- ELSIF KwAhead ("DIV") THEN
|
|
|
- GetWord () ; op := TkDiv
|
|
|
- ELSIF KwAhead ("MOD") THEN
|
|
|
- GetWord () ; op := TkMod
|
|
|
- ELSIF KwAhead ("AND") THEN
|
|
|
- GetWord () ; op := TkAnd
|
|
|
- ELSIF KwAhead ("SHL") THEN
|
|
|
- GetWord () ; op := OpShl
|
|
|
- ELSIF KwAhead ("SHR") THEN
|
|
|
- GetWord () ; op := OpShr
|
|
|
- ELSE
|
|
|
RETURN
|
|
|
END ;
|
|
|
- left := r ;
|
|
|
- IF left.cls = TSet THEN
|
|
|
- (* Set intersection. Same push-before-the-right rule as ParseAdd. *)
|
|
|
- IF op = OpMul THEN
|
|
|
- EmPushSetAddr (left) ;
|
|
|
- ParseNeg (right) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF right.cls # TSet THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- SetBinEmit (0, left, right, r)
|
|
|
- ELSE
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- ELSE
|
|
|
- SaveLeft (left) ;
|
|
|
- ParseNeg (right) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF right.cls = TSet THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- BinOpEmit (op, left, right, r)
|
|
|
- END
|
|
|
- END
|
|
|
-END ParseMul ;
|
|
|
-
|
|
|
-PROCEDURE ParseNeg (VAR r : ERes) ;
|
|
|
-BEGIN
|
|
|
- Skip () ;
|
|
|
- IF CurCh () = '+' THEN
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- ParseNeg (r) ;
|
|
|
+ Err (ENoLib) ;
|
|
|
RETURN
|
|
|
- ELSIF CurCh () = '-' THEN
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- ParseNeg (r) ;
|
|
|
- IF r.cls = TReal THEN
|
|
|
- r.idx := NewScratchReal () ;
|
|
|
- EmCopyRealTo (symtab [r.idx].off, r) ;
|
|
|
- EmXorByteGlob (symtab [r.idx].off + 5, 80H) ;
|
|
|
- r.kind := 1 ;
|
|
|
- r.cls := TReal ;
|
|
|
- r.sz := 6 ;
|
|
|
- r.boff := 0
|
|
|
- ELSIF r.kind = 0 THEN
|
|
|
- r.imm := VAL (LONGINT, W16 (0 - r.imm))
|
|
|
- ELSE
|
|
|
- LoadAtom (r) ;
|
|
|
- EmNegAx () ;
|
|
|
- r.kind := 2
|
|
|
+ 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 ;
|
|
|
- RETURN
|
|
|
- ELSIF KwAhead ("NOT") THEN
|
|
|
- GetWord () ;
|
|
|
- ParseNeg (r) ;
|
|
|
- (* TPSRC9 neglevel branches on the operand's type before emitting
|
|
|
- anything: CMP CL,#$0A (integer) -> NOT AX, CMP CL,#$0B (boolean)
|
|
|
- -> XOR AL,#01, anything else -> error. This used to emit NOT AX
|
|
|
- for both, so `not (a = a)' produced 0FFFEh and the runtime's
|
|
|
- wrbool test ([BP+4] <> 0) read it as TRUE.
|
|
|
-
|
|
|
- The integer constant fold stays: the 16 bits are the same either
|
|
|
- way. A boolean constant must not go through BitNot - 0FFFFH-1 is
|
|
|
- 0FFFEh, which wrbool also reads as TRUE - so it is loaded and
|
|
|
- xor-ed, exactly as neglevel does it. *)
|
|
|
- IF r.cls = TBool THEN
|
|
|
- LoadAtom (r) ;
|
|
|
- EmXorAl01 () ;
|
|
|
- r.kind := 2
|
|
|
- ELSIF r.cls = TScalar THEN
|
|
|
- IF r.kind = 0 THEN
|
|
|
- r.imm := BitNot (r.imm)
|
|
|
+ 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
|
|
|
- LoadAtom (r) ;
|
|
|
- EmNotAx () ;
|
|
|
- r.kind := 2
|
|
|
+ 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
|
|
|
- ELSE
|
|
|
- Err (ETypeErr)
|
|
|
END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseAtom (r)
|
|
|
-END ParseNeg ;
|
|
|
-
|
|
|
-PROCEDURE WithLookup (nm : ARRAY OF CHAR ; VAR r : ERes) : BOOLEAN ;
|
|
|
-(* Resolve a bare identifier against the active WITH scopes, innermost first.
|
|
|
- ISO Pascal lets a record field shadow an outer declaration, so this is
|
|
|
- consulted BEFORE Search. The result is filled exactly as a variable
|
|
|
- reference: kind 1 (base symbol + boff) for a record variable or a
|
|
|
- constant-index element, kind 5 (address in DI) for a run-time-indexed one,
|
|
|
- where the base is reloaded from the WITH slot because the body may have
|
|
|
- used DI. *)
|
|
|
-VAR w, fi : CARDINAL ;
|
|
|
- found : BOOLEAN ;
|
|
|
-BEGIN
|
|
|
- w := withN ;
|
|
|
- WHILE w > 0 DO
|
|
|
- DEC (w) ;
|
|
|
- fi := withFF [w] ;
|
|
|
- found := FALSE ;
|
|
|
- WHILE (fi < withFL [w]) AND NOT found DO
|
|
|
- IF NameEq (fields [fi].name, nm) THEN
|
|
|
- found := TRUE
|
|
|
- ELSE
|
|
|
- INC (fi)
|
|
|
- END
|
|
|
+ (* `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 ;
|
|
|
- IF found THEN
|
|
|
- IF withIsDI [w] THEN
|
|
|
- EmLdDiGlob (withSlot [w]) ;
|
|
|
- IF fields [fi].off # 0 THEN
|
|
|
- EmAddDiImm (fields [fi].off)
|
|
|
- END ;
|
|
|
- r.kind := 5
|
|
|
- ELSE
|
|
|
- r.kind := 1 ;
|
|
|
- r.setoff := symtab [withIdx [w]].off ;
|
|
|
- r.boff := W16 (VAL (LONGINT, withBoff [w])
|
|
|
- + VAL (LONGINT, fields [fi].off))
|
|
|
- END ;
|
|
|
- r.idx := withIdx [w] ;
|
|
|
- r.cls := fields [fi].cls ;
|
|
|
- r.sz := fields [fi].size ;
|
|
|
- r.fldFirst := fields [fi].fldFirst ;
|
|
|
- r.fldLast := fields [fi].fldLast ;
|
|
|
- r.arrIdx := fields [fi].arrIdx ;
|
|
|
- r.ptrElem := fields [fi].ptrElem ;
|
|
|
- r.hasBounds := ((fields [fi].cls = TScalar) OR (fields [fi].cls = TEnum)
|
|
|
- OR (fields [fi].cls = TChar)) AND
|
|
|
- (fields [fi].lo # fields [fi].hi) ;
|
|
|
- r.blo := fields [fi].lo ; r.bhi := fields [fi].hi ;
|
|
|
- IF r.cls = TSet THEN
|
|
|
- r.setbase := fields [fi].elem ;
|
|
|
- r.setsize := fields [fi].size
|
|
|
- END ;
|
|
|
- r.chr := FALSE ;
|
|
|
- RETURN TRUE
|
|
|
- END
|
|
|
- END ;
|
|
|
- RETURN FALSE
|
|
|
-END WithLookup ;
|
|
|
-
|
|
|
-PROCEDURE ParseAtom (VAR r : ERes) ;
|
|
|
-(* const | variable | func(params) | '(' expr ')' | '[' set ']' *)
|
|
|
-VAR idx : CARDINAL ;
|
|
|
- strf : BOOLEAN ;
|
|
|
- quoted : BOOLEAN ;
|
|
|
- ssize, sbase : CARDINAL ;
|
|
|
- sbuf : ARRAY [0..31] OF CHAR ;
|
|
|
- uj1, uj2 : CARDINAL ;
|
|
|
- litStart, scratch, asciiAddr, savePos : CARDINAL ;
|
|
|
- dyn, acc, conArg : ERes ;
|
|
|
-BEGIN
|
|
|
- r.chr := FALSE ; (* default: not a quoted char literal *)
|
|
|
- Skip () ;
|
|
|
- IF CurCh () = '(' THEN
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF CurCh () = '[' THEN
|
|
|
- (* An inline set literal. A literal whose first element is a variable
|
|
|
- (e.g. `[Storage[Index]]') is dynamic: evaluate the element once and
|
|
|
- mark it kind 9, to be materialised when the target's base/size is
|
|
|
- known. Constant literals stay code-resident. *)
|
|
|
- savePos := srcPos ;
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- Skip () ;
|
|
|
- IF Alpha (CurCh ()) THEN
|
|
|
- GetWord () ;
|
|
|
- IF Search (wrd, idx) AND ((symtab [idx].tag = KVar) OR
|
|
|
- (symtab [idx].tag = KFunc)) THEN
|
|
|
- srcPos := savePos + 1 ;
|
|
|
- ParseExpr (dyn) ;
|
|
|
- ExpectDelim (']', ENoSemi) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF (dyn.cls # TScalar) AND (dyn.cls # TChar) AND
|
|
|
- (dyn.cls # TEnum) THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- scratch := NewScratchWord () ;
|
|
|
- LoadAtom (dyn) ;
|
|
|
- EmStoreVar (FALSE, symtab [scratch].off, 2) ;
|
|
|
- r.kind := 9 ;
|
|
|
- r.cls := TSet ;
|
|
|
- r.setbase := 0 ;
|
|
|
- r.setsize := 0 ;
|
|
|
- r.dynElem := scratch ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- END ;
|
|
|
- srcPos := savePos ;
|
|
|
- ssize := 32 ;
|
|
|
- sbase := 0 ;
|
|
|
- IF RdSetLiteral (sbase, ssize, sbuf) THEN
|
|
|
- r.kind := 7 ;
|
|
|
- r.cls := TSet ;
|
|
|
- r.setoff := EmSetBlob (sbuf, ssize) ;
|
|
|
- r.setbase := sbase ;
|
|
|
- r.setsize := ssize
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF (CurCh () = '$') OR (Digit (CurCh ())) OR (ORD (CurCh ()) = AposC)
|
|
|
- OR (CurCh () = '^') OR (CurCh () = '#') THEN
|
|
|
- (* remember that this was a quoted literal BEFORE RdConst consumes it:
|
|
|
- RdConst reports a 1-character literal as TScalar (its char code),
|
|
|
- which is right for "c := 'a'" but would make writeln('a') print 97.
|
|
|
- Mark it so the writer picks the char entry, not the integer one. A
|
|
|
- caret (^M) or decimal (#27) character constant is a character too. *)
|
|
|
- quoted := (ORD (CurCh ()) = AposC) OR (CurCh () = '^')
|
|
|
- OR (CurCh () = '#') ;
|
|
|
- litStart := srcPos ;
|
|
|
- RdConst (r.imm, r.cls, strf) ;
|
|
|
- r.chr := quoted AND (r.cls = TScalar) AND NOT strf ;
|
|
|
- IF r.cls = TReal THEN
|
|
|
- (* A REAL literal is converted at run time by ascreal. Keep the
|
|
|
- literal text as an ASCIIZ code blob and call real_val into a
|
|
|
- six-byte scratch; the expression then behaves like a REAL
|
|
|
- variable whose address is the scratch. *)
|
|
|
- scratch := NewScratchReal () ;
|
|
|
- asciiAddr := EmAsciiZLiteral (litStart, srcPos) ;
|
|
|
- EmPushVarAddr (FALSE, symtab [scratch].off) ;
|
|
|
- EmPushVarAddr (FALSE, asciiAddr) ;
|
|
|
- DropC (EmCall (TU_RealVal)) ;
|
|
|
- EmAddSp (4) ;
|
|
|
- EmLeaDi (FALSE, symtab [scratch].off) ;
|
|
|
- r.idx := scratch ;
|
|
|
- r.kind := 5 ;
|
|
|
- r.cls := TReal ;
|
|
|
- r.sz := 6 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF strf THEN
|
|
|
- (* A string literal is legal here as a *value* - it is not rejected
|
|
|
- at this point, because writeln('hi') needs it and IoCall is the
|
|
|
- only place that knows how to emit one. Everywhere else the
|
|
|
- literal has to end up as a machine word, and that is caught by
|
|
|
- LoadAtom, which refuses a TString. *)
|
|
|
- r.strx := rdStrX ;
|
|
|
- r.kind := 3 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- r.kind := 0 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF NOT Alpha (CurCh ()) THEN
|
|
|
- Err (EUnknown) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- GetWord () ;
|
|
|
- IF WithLookup (wrd, r) THEN
|
|
|
- ParseSub (r) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF NameEq (wrd, "NIL") THEN
|
|
|
- r.kind := 0 ;
|
|
|
- r.cls := TPtr ;
|
|
|
- r.imm := 0 ;
|
|
|
- r.sz := 2 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF NameEq (wrd, "ADDR") THEN
|
|
|
- (* Addr(x): the run-time address of x, as a pointer value in AX. TP3
|
|
|
- spells this Addr; the @ operator is a later Turbo spelling and is not
|
|
|
- part of the TP3 subset yet. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- Skip () ;
|
|
|
- IF NOT Alpha (CurCh ()) THEN
|
|
|
- Err (EUnknown) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- GetWord () ;
|
|
|
- ParseVar (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
+ ParseExpr (src) ;
|
|
|
IF NOT OK () THEN
|
|
|
RETURN
|
|
|
END ;
|
|
|
- IF r.kind = 5 THEN
|
|
|
- EmMovAxDi ()
|
|
|
- ELSIF r.kind = 1 THEN
|
|
|
- IF symtab [r.idx].isVar THEN
|
|
|
- LoadSymVar (r.idx, symtab [r.idx].off, 2)
|
|
|
- ELSE
|
|
|
- EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
|
|
|
- EmPopAx ()
|
|
|
- END
|
|
|
- ELSE
|
|
|
+ IF src.cls # TSet THEN
|
|
|
Err (ETypeErr) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TPtr ;
|
|
|
- r.sz := 2 ;
|
|
|
- r.idx := 0 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF NameEq (wrd, "SEG") THEN
|
|
|
- (* TP3 Seg(x): the current DS. The argument is parsed for its type
|
|
|
- and side effects; the .COM has one segment. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
+ IF src.kind = 9 THEN
|
|
|
+ MaterializeDyn (src, r.setbase, r.setsize)
|
|
|
END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- IF NOT OK () THEN
|
|
|
+ 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 ;
|
|
|
- EmMovAxDs () ; (* MOV AX,DS *)
|
|
|
- r.kind := 2 ; r.cls := TScalar ; r.sz := 2 ;
|
|
|
+ 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 NameEq (wrd, "OFS") THEN
|
|
|
- (* TP3 Ofs(x): the run-time address of x. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- Skip () ;
|
|
|
- IF NOT Alpha (CurCh ()) THEN
|
|
|
- Err (EUnknown) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- GetWord () ;
|
|
|
- ParseVar (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
+ 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 ;
|
|
|
- IF r.kind = 5 THEN
|
|
|
- EmMovAxDi ()
|
|
|
- ELSIF r.kind = 1 THEN
|
|
|
- EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
|
|
|
- EmPopAx ()
|
|
|
+ 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 (ETypeErr) ;
|
|
|
- RETURN
|
|
|
+ Err (ENoLib)
|
|
|
END ;
|
|
|
- r.kind := 2 ; r.cls := TScalar ; r.sz := 2 ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF NOT Search (wrd, idx) THEN
|
|
|
- Err (EUnknown) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- IF (symtab [idx].tag = KVar) AND (symtab [idx].resvar # 0) THEN
|
|
|
- (* A function's result variable shadows its own name inside the body;
|
|
|
- a following '(' means this is a recursive call, not a read of the
|
|
|
- result slot. *)
|
|
|
- Skip () ;
|
|
|
- IF CurCh () = '(' THEN
|
|
|
- idx := symtab [idx].resvar
|
|
|
- END
|
|
|
- END ;
|
|
|
- IF symtab [idx].tag = KConst THEN
|
|
|
- r.kind := 0 ;
|
|
|
- r.imm := symtab [idx].lval ;
|
|
|
- r.cls := symtab [idx].cls ;
|
|
|
- RETURN
|
|
|
- ELSIF symtab [idx].tag = KFunc THEN
|
|
|
- ParseCall (idx) ;
|
|
|
- IF symtab [idx].cls = TReal THEN
|
|
|
- (* A REAL function returns into the caller's six-byte scratch; DI is
|
|
|
- reloaded with its address so real consumers can use the value. *)
|
|
|
- EmLeaDi (FALSE, symtab [callScratch].off) ;
|
|
|
- r.kind := 5 ;
|
|
|
- r.cls := TReal ;
|
|
|
- r.sz := 6
|
|
|
- ELSE
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := symtab [idx].cls
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KType) AND (symtab [idx].cls = TChar)
|
|
|
- AND (CurCh () = '(') THEN
|
|
|
- (* TP3 also spells the character cast `Char(n)', not only `Chr(n)'. *)
|
|
|
- DropCh (GetCh ()) ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
+ 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 (r.cls # TScalar) AND (r.cls # TChar) THEN
|
|
|
+ IF src.cls # TString THEN
|
|
|
Err (ETypeErr) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- IF r.kind = 0 THEN
|
|
|
- r.imm := VAL (LONGINT, W16 (r.imm) MOD 256) ;
|
|
|
- r.chr := TRUE
|
|
|
- ELSE
|
|
|
- LoadAtom (r) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.chr := FALSE
|
|
|
- END ;
|
|
|
- r.cls := TChar ;
|
|
|
- r.sz := 1 ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KVar) OR (symtab [idx].tag = KType) THEN
|
|
|
- (* ParseVar initialises boff to 0 and then ParseSub folds any constant
|
|
|
- subscript into it. Do NOT reset boff here: doing so after ParseVar
|
|
|
- returns threw away the subscript, so s[i] read/wrote off+0 (the
|
|
|
- length byte) while still reporting itself as a char. This was
|
|
|
- latent for arrays because an array cannot be declared yet, so no
|
|
|
- fixture had ever exercised the fold. *)
|
|
|
- ParseVar (r) ;
|
|
|
+ EmPushStrAddr (src) ;
|
|
|
+ LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
|
|
|
+ EmPushAx () ;
|
|
|
+ EmMovCxi ((VarSize (r) - 1) MOD 10000H) ;
|
|
|
+ DropC (EmCall (TU_StrStore)) ;
|
|
|
+ EmAddSp (4) ;
|
|
|
RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Chr) THEN
|
|
|
- (* Chr(n): the character with code n. A constant folds; otherwise the
|
|
|
- integer is loaded and its class becomes CHAR. The value is one byte,
|
|
|
- so an assignment stores AL and a CHAR writer uses AL. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF (r.cls # TScalar) AND (r.cls # TChar) THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
+ 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 ;
|
|
|
- IF r.kind = 0 THEN
|
|
|
- r.imm := VAL (LONGINT, W16 (r.imm) MOD 256) ;
|
|
|
- r.chr := TRUE
|
|
|
- ELSE
|
|
|
- LoadAtom (r) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.chr := FALSE
|
|
|
- END ;
|
|
|
- r.cls := TChar ;
|
|
|
- r.sz := 1 ;
|
|
|
+ StoreVarIndPrepSym (r.idx) ;
|
|
|
+ ParseExpr (src) ;
|
|
|
+ LoadAtom (src) ;
|
|
|
+ EmPopDi () ;
|
|
|
+ EmStoreInd (VarSize (r)) ;
|
|
|
RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Eof) THEN
|
|
|
- (* Eof(F): text/typed-file end of file. The runtime compares the DOS
|
|
|
- current position with the file size and also remembers a ^Z seen by
|
|
|
- the text reader. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- IF OK () THEN
|
|
|
- IF (r.kind = 1) AND
|
|
|
- ((r.cls = TText) OR (r.cls = TFile)) THEN
|
|
|
- EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
|
|
|
- DropC (EmCall (TU_FileEof)) ;
|
|
|
- EmAddSp (2) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TBool ;
|
|
|
- r.chr := FALSE
|
|
|
+ END ;
|
|
|
+ IF (r.cls = TString) AND (VarSize (r) > 1) THEN
|
|
|
+ (* s := <string literal>. 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
|
|
|
- Err (ETypeErr)
|
|
|
- END
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_IoResult) THEN
|
|
|
- (* IOResult: the last file operation's DOS status; reading it clears the
|
|
|
- slot in the runtime. It is a no-argument function. *)
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- END ;
|
|
|
- DropC (EmCall (TU_IoResult)) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TScalar ;
|
|
|
- r.chr := FALSE ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_UpCase) THEN
|
|
|
- (* UpCase(c): a CHAR function. A constant folds; otherwise AL is
|
|
|
- mapped 'a'..'z' -> 'A'..'Z' and left alone outside that range. The
|
|
|
- test is JL/JG (signed), which is the same answer for 0..127 chars and
|
|
|
- leaves 128..255 unchanged; it also stays inside the four branch
|
|
|
- conditions this compiler declares (check_8086's set). *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- IF NOT OK () THEN
|
|
|
+ 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 (r.cls # TChar) AND (r.cls # TScalar) THEN
|
|
|
- Err (ETypeErr) ; (* the STRING form is not implemented *)
|
|
|
+ IF (src.cls # TString) THEN
|
|
|
+ Err (ENoLib) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- IF r.kind = 0 THEN
|
|
|
- IF (r.imm >= VAL (LONGINT, ORD ('a')))
|
|
|
- AND (r.imm <= VAL (LONGINT, ORD ('z'))) THEN
|
|
|
- r.imm := r.imm - 32
|
|
|
+ IF src.kind # 3 THEN
|
|
|
+ (* s := <string variable>. 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 ;
|
|
|
- r.kind := 0 ;
|
|
|
- r.cls := TChar ;
|
|
|
- r.chr := TRUE ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadAtom (r) ;
|
|
|
- EmCmpAlImm (ORD ('a')) ;
|
|
|
- uj1 := EmJcc (8CH, 0) ; (* JL -> leave it *)
|
|
|
- EmCmpAlImm (ORD ('z')) ;
|
|
|
- uj2 := EmJcc (8FH, 0) ; (* JG -> leave it *)
|
|
|
- EmSubAlImm (32) ;
|
|
|
- SetPatTgt (uj1, pc) ;
|
|
|
- SetPatTgt (uj2, pc) ;
|
|
|
- EmMovAh0 () ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TChar ;
|
|
|
- r.chr := FALSE ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND
|
|
|
- ((symtab [idx].cls = BI_Succ) OR (symtab [idx].cls = BI_Pred)) THEN
|
|
|
- (* Succ(x) / Pred(x) on an ordinal. CALC's `FX := Succ(FX)' is the
|
|
|
- first use. A constant folds; otherwise load the value and INC/DEC
|
|
|
- it, preserving the operand's class so an assignment back to a CHAR
|
|
|
- subrange stores one byte as before. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
+ 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 ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
+ n := strLen [src.strx] ;
|
|
|
+ IF n > VarSize (r) - 1 THEN
|
|
|
+ n := VarSize (r) - 1
|
|
|
END ;
|
|
|
- IF (r.cls # TChar) AND (r.cls # TScalar) AND (r.cls # TEnum) THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF r.kind = 0 THEN
|
|
|
- IF symtab [idx].cls = BI_Succ THEN
|
|
|
- r.imm := VAL (LONGINT, W16 (r.imm + 1))
|
|
|
- ELSE
|
|
|
- r.imm := VAL (LONGINT, W16 (r.imm - 1))
|
|
|
- END
|
|
|
- ELSE
|
|
|
- LoadAtom (r) ;
|
|
|
- IF symtab [idx].cls = BI_Succ THEN
|
|
|
- EmIncAx ()
|
|
|
- ELSE
|
|
|
- EmDecAx ()
|
|
|
- END ;
|
|
|
- r.kind := 2
|
|
|
- END ;
|
|
|
- r.chr := FALSE ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_KeyPressed) THEN
|
|
|
- (* KeyPressed: a boolean FUNCTION with no argument, and TP3 lets it be
|
|
|
- written without a parameter list (`until KeyPressed'). *)
|
|
|
- EmCrtSeq (CrtKey) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TBool ;
|
|
|
- r.chr := FALSE ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND
|
|
|
- ((symtab [idx].cls = BI_Abs) OR (symtab [idx].cls = BI_Sqrt)
|
|
|
- OR (symtab [idx].cls = BI_Ln) OR (symtab [idx].cls = BI_Exp)
|
|
|
- OR (symtab [idx].cls = BI_Sin) OR (symtab [idx].cls = BI_Cos)
|
|
|
- OR (symtab [idx].cls = BI_Arctan) OR (symtab [idx].cls = BI_Int)) THEN
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF (r.cls = TScalar) AND (r.kind = 0) THEN
|
|
|
- scratch := NewScratchReal () ;
|
|
|
- EmCopyRealTo (symtab [scratch].off, r) ;
|
|
|
- r.idx := scratch ; r.kind := 1 ; r.cls := TReal ;
|
|
|
- r.sz := 6 ; r.boff := 0
|
|
|
- END ;
|
|
|
- IF r.cls # TReal THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF symtab [idx].cls = BI_Abs THEN
|
|
|
- RealUnary (TU_RealAbs, r)
|
|
|
- ELSIF symtab [idx].cls = BI_Sqrt THEN
|
|
|
- RealUnary (TU_RealSqrt, r)
|
|
|
- ELSIF symtab [idx].cls = BI_Ln THEN
|
|
|
- RealUnary (TU_RealLn, r)
|
|
|
- ELSIF symtab [idx].cls = BI_Exp THEN
|
|
|
- RealUnary (TU_RealExp, r)
|
|
|
- ELSIF symtab [idx].cls = BI_Sin THEN
|
|
|
- RealUnary (TU_RealSin, r)
|
|
|
- ELSIF symtab [idx].cls = BI_Cos THEN
|
|
|
- RealUnary (TU_RealCos, r)
|
|
|
- ELSIF symtab [idx].cls = BI_Arctan THEN
|
|
|
- RealUnary (TU_RealArctan, r)
|
|
|
- ELSE
|
|
|
- RealUnary (TU_RealIntFunc, r)
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Sqr) THEN
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF r.cls # TReal THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
+ 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 ;
|
|
|
- RealBin (OpMul, r, r, r) ;
|
|
|
RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_SizeOf) THEN
|
|
|
- IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ;
|
|
|
- savePos := srcPos ;
|
|
|
- Skip () ;
|
|
|
- IF Alpha (CurCh ()) THEN
|
|
|
- GetWord () ;
|
|
|
- IF Search (wrd, idx) AND (symtab [idx].tag = KType) THEN
|
|
|
- r.kind := 0 ; r.cls := TScalar ; r.imm := symtab [idx].size ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
+ 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
|
|
|
- END ;
|
|
|
- srcPos := savePos ;
|
|
|
- ParseExpr (r) ;
|
|
|
- IF OK () THEN
|
|
|
- r.kind := 0 ; r.cls := TScalar ; r.imm := VarSize (r)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND
|
|
|
- ((symtab [idx].cls = BI_FilePos) OR (symtab [idx].cls = BI_FileSize)) THEN
|
|
|
- IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- IF NOT OK () OR (r.kind # 1) OR
|
|
|
- ((r.cls # TFile) AND (r.cls # TText) AND (r.cls # TUntyp)) THEN
|
|
|
- Err (ETypeErr) ; RETURN
|
|
|
- END ;
|
|
|
- EmMovAxi (symtab [r.idx].elem) ; EmPushAx () ;
|
|
|
- EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
|
|
|
- IF symtab [idx].cls = BI_FilePos THEN
|
|
|
- DropC (EmCall (TU_FilePos))
|
|
|
- ELSE
|
|
|
- DropC (EmCall (TU_FileSize))
|
|
|
- END ;
|
|
|
- EmAddSp (4) ;
|
|
|
- r.kind := 2 ; r.cls := TScalar ; r.sz := 2 ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Random) THEN
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- IF NOT OK () THEN RETURN END ;
|
|
|
- IF (r.cls # TScalar) AND (r.cls # TChar) THEN
|
|
|
- Err (ETypeErr) ; RETURN
|
|
|
END ;
|
|
|
- LoadAtom (r) ; EmPushAx ()
|
|
|
- ELSE
|
|
|
- EmMovAxi (0) ; EmPushAx ()
|
|
|
- END ;
|
|
|
- DropC (EmCall (TU_Random)) ; EmAddSp (2) ;
|
|
|
- r.kind := 2 ; r.cls := TScalar ; r.sz := 2 ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Pos) THEN
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- IF OK () AND (r.cls = TString) THEN
|
|
|
- EmPushStrAddr (r) ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (r) ;
|
|
|
- IF OK () AND (r.cls = TString) THEN
|
|
|
- EmPushStrAddr (r) ;
|
|
|
- DropC (EmCall (TU_StrPos)) ;
|
|
|
- EmAddSp (4) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TScalar ;
|
|
|
- r.sz := 2
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Concat) THEN
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF CurCh () = ')' THEN
|
|
|
- scratch := NewScratchStr () ;
|
|
|
- EmStoreVar (FALSE, symtab [scratch].off, 1) ;
|
|
|
- r.kind := 1 ; r.idx := scratch ; r.cls := TString ; r.sz := 256 ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- IF OK () AND NOT StrOperand (r) THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF OK () AND MatchDelim (',') THEN
|
|
|
- LOOP
|
|
|
- ParseExpr (conArg) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF NOT StrOperand (conArg) THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- StrConcat (OpAdd, r, conArg, acc) ;
|
|
|
- r := acc ;
|
|
|
- IF NOT MatchDelim (',') THEN
|
|
|
- EXIT
|
|
|
- END
|
|
|
- END
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Copy) THEN
|
|
|
- (* Copy(S, start, len): a counted-string result in a fresh 256-byte
|
|
|
- scratch. S's address is parked while start/len are parsed, then the
|
|
|
- four words are re-pushed in the runtime's [source,dest,start,len]
|
|
|
- order. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- IF OK () AND (r.cls = TString) AND
|
|
|
- ((r.kind = 1) OR (r.kind = 3) OR (r.kind = 5)) THEN
|
|
|
- EmPushStrAddr (r) ; (* park S *)
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (r) ;
|
|
|
- IF OK () AND ((r.cls = TScalar) OR (r.cls = TChar)) THEN
|
|
|
- LoadAtom (r) ; EmPushAx () ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (r) ;
|
|
|
- IF OK () AND ((r.cls = TScalar) OR (r.cls = TChar)) THEN
|
|
|
- LoadAtom (r) ; EmPushAx () ;
|
|
|
- scratch := NewScratchStr () ;
|
|
|
- EmPushVarAddr (FALSE, symtab [scratch].off) ;
|
|
|
- EmPopAx () ; (* dest *)
|
|
|
- EmPopBx () ; (* len *)
|
|
|
- EmPopCx () ; (* start *)
|
|
|
- EmPopDx () ; (* source *)
|
|
|
- EmPushBx () ; EmPushCx () ; EmPushAx () ; EmPushDx () ;
|
|
|
- DropC (EmCall (TU_StrCopy)) ;
|
|
|
- EmAddSp (8) ;
|
|
|
- r.kind := 1 ; r.idx := scratch ; r.cls := TString ;
|
|
|
- r.sz := 256 ; r.boff := 0 ; r.chr := FALSE
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
+ EmPushDi () ;
|
|
|
+ ParseExpr (src) ;
|
|
|
+ LoadAtom (src) ;
|
|
|
+ IF BoundsOf (r, blo, bhi) THEN
|
|
|
+ EmitBoundsCheck (blo, bhi, 17)
|
|
|
END ;
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Ord) THEN
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF (r.cls # TChar) AND (r.cls # TEnum) AND (r.cls # TScalar)
|
|
|
- AND (r.cls # TBool) THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
+ EmPopDi () ; (* DI := the destination again *)
|
|
|
+ EmStoreInd (VarSize (r)) ; (* [DI] := AL or AX *)
|
|
|
RETURN
|
|
|
END ;
|
|
|
- LoadAtom (r) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TScalar ;
|
|
|
- r.chr := FALSE ;
|
|
|
+ (* 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
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND
|
|
|
- ((symtab [idx].cls = BI_Round) OR (symtab [idx].cls = BI_Trunc)) THEN
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
+ 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 ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
+ Statmnt () ;
|
|
|
IF NOT OK () THEN
|
|
|
RETURN
|
|
|
END ;
|
|
|
- IF r.cls = TReal THEN
|
|
|
- IF r.kind = 5 THEN
|
|
|
- EmPushDi ()
|
|
|
- ELSIF r.kind = 1 THEN
|
|
|
- EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
|
|
|
- ELSE
|
|
|
- Err (ETypeErr) ;
|
|
|
+ IF NOT MatchDelim (';') THEN
|
|
|
+ PeekKw (tok) ;
|
|
|
+ IF tok = TkEnd THEN
|
|
|
+ DropB (MatchKey (tok)) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- IF symtab [idx].cls = BI_Round THEN
|
|
|
- EmMovAxi (1)
|
|
|
- ELSE
|
|
|
- EmMovAxi (0)
|
|
|
- END ;
|
|
|
- EmPushAx () ;
|
|
|
- DropC (EmCall (TU_RealToInt)) ;
|
|
|
- EmAddSp (4) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TScalar ;
|
|
|
- r.sz := 2 ;
|
|
|
- RETURN
|
|
|
- ELSIF (r.cls = TScalar) OR (r.cls = TChar) OR (r.cls = TEnum) THEN
|
|
|
- LoadAtom (r) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TScalar ;
|
|
|
- r.sz := 2 ;
|
|
|
- RETURN
|
|
|
- ELSE
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ELSIF (symtab [idx].tag = KBuiltin) AND (symtab [idx].cls = BI_Length) THEN
|
|
|
- (* LENGTH (s): the string's length byte, loaded inline. No runtime
|
|
|
- entry, and no address is pushed - a string's value already carries its
|
|
|
- length at [addr]. A literal is emitted inline (EmStrBlob) and the
|
|
|
- byte is read from that image offset. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
Err (ENoSemi) ;
|
|
|
RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (r) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF r.cls # TString THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF r.kind = 5 THEN
|
|
|
- (* A string field/element addressed by DI (e.g. a typed-constant
|
|
|
- array element): its length byte is at [DI]. *)
|
|
|
- EmLdAlDi () ; EmMovAh0 ()
|
|
|
- ELSIF (r.kind = 1) AND symtab [r.idx].isVar THEN
|
|
|
- (* VAR string: the slot holds the address; read the length byte
|
|
|
- through that pointer. *)
|
|
|
- IF r.boff # 0 THEN
|
|
|
- Err (ENoLib)
|
|
|
- ELSE
|
|
|
- EmLoadVarIndSym (r.idx, 1)
|
|
|
- END
|
|
|
- ELSIF r.kind = 1 THEN
|
|
|
- LoadSymVar (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H, 1)
|
|
|
- ELSIF r.kind = 3 THEN
|
|
|
- EmLoadVar (FALSE, EmStrBlob (r), 1)
|
|
|
- ELSE
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- EmMovAh0 () ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := TScalar ;
|
|
|
- r.chr := FALSE ;
|
|
|
- RETURN
|
|
|
- ELSE
|
|
|
- Err (EUnknown)
|
|
|
+ END
|
|
|
END
|
|
|
-END ParseAtom ;
|
|
|
+END Compound ;
|
|
|
|
|
|
-PROCEDURE AddPend (kind, who, place : CARDINAL) ;
|
|
|
+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 nPend < MaxPend THEN
|
|
|
- pend [nPend].kind := kind ;
|
|
|
- pend [nPend].who := who ;
|
|
|
- pend [nPend].place := place ;
|
|
|
- INC (nPend)
|
|
|
+ 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
|
|
|
- Err (ECompOvf)
|
|
|
- END
|
|
|
-END AddPend ;
|
|
|
-
|
|
|
-PROCEDURE ParmSlot (idx, k : CARDINAL) : CARDINAL ;
|
|
|
-(* The stack slot of argument k (0-based) of procedure/function idx, from the
|
|
|
- parameter list recorded on the symbol. Out of range means the source passed
|
|
|
- more arguments than there are parameters: keep the old two-byte assumption
|
|
|
- rather than inventing an arity error here. *)
|
|
|
-VAR pi : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- IF (symtab [idx].parmCount = 0) OR (k >= symtab [idx].parmCount) THEN
|
|
|
- RETURN 2
|
|
|
- END ;
|
|
|
- pi := symtab [idx].parmFirst + k ;
|
|
|
- RETURN ParamSlotBytes (symtab [pi])
|
|
|
-END ParmSlot ;
|
|
|
-
|
|
|
-PROCEDURE ParmIsVar (idx, k : CARDINAL) : BOOLEAN ;
|
|
|
-(* Is argument k (0-based) of procedure/function idx declared VAR? Out of
|
|
|
- range means the source passed more arguments than there are formals; treat
|
|
|
- it as a value parameter, as ParmSlot already does. *)
|
|
|
-VAR pi : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- IF (symtab [idx].parmCount = 0) OR (k >= symtab [idx].parmCount) THEN
|
|
|
- RETURN FALSE
|
|
|
- END ;
|
|
|
- pi := symtab [idx].parmFirst + k ;
|
|
|
- RETURN symtab [pi].isVar
|
|
|
-END ParmIsVar ;
|
|
|
-
|
|
|
-PROCEDURE EmCallMost (idx, cleanup : CARDINAL) ;
|
|
|
-(* emit the call to sym 'idx' and clean up `cleanup' bytes of arguments, which
|
|
|
- is the SUM of their slot sizes - not 2 per argument once a slot can be
|
|
|
- larger than a word. *)
|
|
|
-VAR p : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- EmitStaticLink (idx) ;
|
|
|
- IF symtab [idx].defnd THEN
|
|
|
- DropC (EmCall (symtab [idx].goPos))
|
|
|
- ELSE
|
|
|
- p := EmCall (0) ;
|
|
|
- AddPend (1, idx, p)
|
|
|
- END ;
|
|
|
- IF cleanup > 0 THEN
|
|
|
- EmAddSp (cleanup)
|
|
|
- END
|
|
|
-END EmCallMost ;
|
|
|
-
|
|
|
-PROCEDURE ParseCallArgs (idx : CARDINAL) ;
|
|
|
-(* '(' already consumed: read args ')' then call.
|
|
|
-
|
|
|
- Each argument is loaded and pushed the moment it has been parsed, which is
|
|
|
- what TPSRC8 cproc/cprlp1/cprlp2 do - CALL exprsave, CALL epushax, one per
|
|
|
- argument, then the CALL. A computed argument (kind 2) exists only in AX,
|
|
|
- so parsing the argument after it would destroy it before the push loop
|
|
|
- ever reached it: `p (a > b, x)' passed x twice.
|
|
|
-
|
|
|
- Pushing in parse order is also the order the callee is laid out for: the
|
|
|
- first argument goes on first and so ends up farthest from BP, and the LAST
|
|
|
- declared parameter is the one at BP+4 (RESUME-TP3.md 3.11). *)
|
|
|
-VAR arg : ERes ;
|
|
|
- nArgs, cleanup, slot, nCopy : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- nArgs := 0 ;
|
|
|
- cleanup := 0 ;
|
|
|
- IF CurCh () = ')' THEN
|
|
|
- DropCh (GetCh ())
|
|
|
- ELSE
|
|
|
- LOOP
|
|
|
- IF nArgs >= 16 THEN
|
|
|
- Err (ECompOvf) ;
|
|
|
- EXIT
|
|
|
- END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- slot := ParmSlot (idx, nArgs) ;
|
|
|
- IF ParmIsVar (idx, nArgs) THEN
|
|
|
- (* VAR formal: push the actual's ADDRESS. Only a variable has
|
|
|
- one; a constant or a computed value is refused rather than
|
|
|
- quietly passed by value. An element with a constant index
|
|
|
- (`s[i]') is a variable too: its address is off+boff, which
|
|
|
- EmPushVarAddr forms directly. *)
|
|
|
- IF arg.kind = 5 THEN
|
|
|
- (* An element/field address already in DI, including a record
|
|
|
- field passed as a VAR actual: Sheet[I,J].Contents. *)
|
|
|
- EmPushDi ()
|
|
|
- ELSIF arg.kind # 1 THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- EXIT
|
|
|
- ELSIF symtab [arg.idx].isVar THEN
|
|
|
- (* Passing a VAR parameter on: its slot already HOLDS the
|
|
|
- address, so push that, not the address of the slot. *)
|
|
|
- IF arg.boff # 0 THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- EXIT
|
|
|
- END ;
|
|
|
- LoadSymVar (arg.idx, symtab [arg.idx].off, 2) ;
|
|
|
- EmPushAx ()
|
|
|
- ELSE
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H)
|
|
|
- END
|
|
|
- ELSIF slot > 2 THEN
|
|
|
- (* A STRING VALUE parameter: push its whole slot, copied.
|
|
|
- `copyN' is at most the slot: an actual shorter than the formal
|
|
|
- leaves the tail untouched, which is harmless because the length
|
|
|
- byte bounds every read. *)
|
|
|
- IF arg.cls = TString THEN
|
|
|
- nCopy := slot ;
|
|
|
- IF arg.kind = 1 THEN
|
|
|
- IF VarSize (arg) < nCopy THEN
|
|
|
- nCopy := VarSize (arg)
|
|
|
- END
|
|
|
- ELSIF arg.kind = 3 THEN
|
|
|
- IF strLen [arg.strx] + 1 < nCopy THEN
|
|
|
- nCopy := strLen [arg.strx] + 1
|
|
|
- END
|
|
|
- ELSE
|
|
|
- Err (ENoLib) ; (* a computed string is not a value *)
|
|
|
- EXIT
|
|
|
- END ;
|
|
|
- EmPushStrSlot (arg, slot, nCopy)
|
|
|
- ELSIF arg.cls = TReal THEN
|
|
|
- EmPushRealSlot (arg, slot)
|
|
|
- ELSE
|
|
|
- Err (ETypeErr) ;
|
|
|
- EXIT
|
|
|
- END
|
|
|
- ELSE
|
|
|
- LoadAtom (arg) ;
|
|
|
- EmPushAx ()
|
|
|
- END ;
|
|
|
- cleanup := cleanup + slot ;
|
|
|
- INC (nArgs) ;
|
|
|
- IF NOT MatchDelim (',') THEN
|
|
|
- EXIT
|
|
|
- END
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- END ;
|
|
|
- EmCallMost (idx, cleanup)
|
|
|
-END ParseCallArgs ;
|
|
|
-
|
|
|
-PROCEDURE ParseCall (idx : CARDINAL) ;
|
|
|
-(* procedure/function call; '(' optional - same parse-then-push as above,
|
|
|
- reached from ParseAtom when a FUNCTION is called in an expression *)
|
|
|
-VAR arg : ERes ;
|
|
|
- nArgs, cleanup, slot, nCopy : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- nArgs := 0 ;
|
|
|
- cleanup := 0 ;
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- IF CurCh () # ')' THEN
|
|
|
- LOOP
|
|
|
- IF nArgs >= 16 THEN
|
|
|
- Err (ECompOvf) ;
|
|
|
- EXIT
|
|
|
- END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- slot := ParmSlot (idx, nArgs) ;
|
|
|
- IF ParmIsVar (idx, nArgs) THEN
|
|
|
- (* A VAR formal in a FUNCTION call: the callee wants the
|
|
|
- address, exactly as ParseCallArgs does for a procedure. This
|
|
|
- path was missing, so `Length(s)' inside a function whose
|
|
|
- formal is `var s' pushed the string's VALUE and the callee
|
|
|
- would have read it as an address. *)
|
|
|
- IF arg.kind = 5 THEN
|
|
|
- EmPushDi ()
|
|
|
- ELSIF arg.kind # 1 THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- EXIT
|
|
|
- ELSIF symtab [arg.idx].isVar THEN
|
|
|
- IF arg.boff # 0 THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- EXIT
|
|
|
- END ;
|
|
|
- LoadSymVar (arg.idx, symtab [arg.idx].off, 2) ;
|
|
|
- EmPushAx ()
|
|
|
- ELSE
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H)
|
|
|
- END
|
|
|
- ELSIF slot > 2 THEN
|
|
|
- (* see ParseCallArgs: push the whole string slot *)
|
|
|
- IF arg.cls = TString THEN
|
|
|
- nCopy := slot ;
|
|
|
- IF arg.kind = 1 THEN
|
|
|
- IF VarSize (arg) < nCopy THEN
|
|
|
- nCopy := VarSize (arg)
|
|
|
- END
|
|
|
- ELSIF arg.kind = 3 THEN
|
|
|
- IF strLen [arg.strx] + 1 < nCopy THEN
|
|
|
- nCopy := strLen [arg.strx] + 1
|
|
|
- END
|
|
|
- ELSE
|
|
|
- Err (ENoLib) ;
|
|
|
- EXIT
|
|
|
- END ;
|
|
|
- EmPushStrSlot (arg, slot, nCopy)
|
|
|
- ELSIF arg.cls = TReal THEN
|
|
|
- EmPushRealSlot (arg, slot)
|
|
|
- ELSE
|
|
|
- Err (ETypeErr) ;
|
|
|
- EXIT
|
|
|
- END
|
|
|
- ELSE
|
|
|
- LoadAtom (arg) ;
|
|
|
- EmPushAx ()
|
|
|
- END ;
|
|
|
- cleanup := cleanup + slot ;
|
|
|
- INC (nArgs) ;
|
|
|
- IF NOT MatchDelim (',') THEN
|
|
|
- EXIT
|
|
|
- END
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- ELSE
|
|
|
- DropCh (GetCh ())
|
|
|
- END
|
|
|
- END ;
|
|
|
- callScratch := 0 ;
|
|
|
- IF symtab [idx].cls = TReal THEN
|
|
|
- callScratch := NewScratchReal () ;
|
|
|
- EmLeaDi (FALSE, symtab [callScratch].off)
|
|
|
- END ;
|
|
|
- EmCallMost (idx, cleanup)
|
|
|
-END ParseCall ;
|
|
|
-
|
|
|
-PROCEDURE ParseExpr (VAR r : ERes) ;
|
|
|
-BEGIN
|
|
|
- ParseCmp (r)
|
|
|
-END ParseExpr ;
|
|
|
-
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-(* statements (TPSRC8) *)
|
|
|
-(* ---------------------------------------------------------------- *)
|
|
|
-
|
|
|
-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 IntToMbf (v : LONGINT ; VAR b : ARRAY OF CHAR) ;
|
|
|
-(* TP3's 6-byte Real, as measured in CALC-PORT.md against the cells holding
|
|
|
- 1, 2, 3, 4 and 5:
|
|
|
-
|
|
|
- value = (1 + N / 2^39) * 2^(E - 129)
|
|
|
-
|
|
|
- byte 0 is E (biased by 129); bytes 1..5 are N, little-endian; the SIGN is
|
|
|
- bit 7 of byte 5 (the book's `sign + 39-bit mantissa'). An all-zero value
|
|
|
- is 0.0. 1 -> 81 00 00 00 00 00, 3 -> 82 00 00 00 00 40,
|
|
|
- 5 -> 83 00 00 00 00 20 - all cross-checked against CALCDEMO.MCS.
|
|
|
-
|
|
|
- Only INTEGER values are converted; real arithmetic and formatting are a
|
|
|
- later stage, and a real RHS that is not a constant or a copy is ENoLib. *)
|
|
|
-VAR a, p, n : LONGINT ;
|
|
|
- e, k, i : CARDINAL ;
|
|
|
- neg : BOOLEAN ;
|
|
|
-BEGIN
|
|
|
- i := 0 ;
|
|
|
- WHILE i < 6 DO
|
|
|
- b [i] := CHR (0) ;
|
|
|
- INC (i)
|
|
|
- END ;
|
|
|
- (* The parser represents a negated 16-bit INTEGER constant as its
|
|
|
- unsigned 16-bit bit pattern (W16), so -1 arrives as 65535. Convert that
|
|
|
- back to a signed value before building a REAL; otherwise `R := -1' would
|
|
|
- become +65535. *)
|
|
|
- IF (v > 32767) AND (v <= 65535) THEN
|
|
|
- v := v - 65536
|
|
|
- END ;
|
|
|
- IF v = 0 THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- neg := v < 0 ;
|
|
|
- IF neg THEN
|
|
|
- a := -v
|
|
|
- ELSE
|
|
|
- a := v
|
|
|
- END ;
|
|
|
- (* k = floor(log2(a)); p = 2^k *)
|
|
|
- p := 1 ;
|
|
|
- k := 0 ;
|
|
|
- WHILE (k < 39) AND (p * 2 <= a) DO
|
|
|
- p := p * 2 ;
|
|
|
- INC (k)
|
|
|
- END ;
|
|
|
- IF k >= 39 THEN
|
|
|
- Err (EConstRange) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- e := 129 + k ;
|
|
|
- b [0] := CHR (e) ;
|
|
|
- n := a - p ;
|
|
|
- i := 39 - k ;
|
|
|
- WHILE i > 0 DO
|
|
|
- n := n * 2 ;
|
|
|
- DEC (i)
|
|
|
- END ;
|
|
|
- i := 1 ;
|
|
|
- WHILE i <= 5 DO
|
|
|
- b [i] := CHR (VAL (CARDINAL, n MOD 256)) ;
|
|
|
- n := n DIV 256 ;
|
|
|
- INC (i)
|
|
|
- END ;
|
|
|
- IF neg THEN
|
|
|
- b [5] := CHR (ORD (b [5]) + 128)
|
|
|
- END
|
|
|
-END IntToMbf ;
|
|
|
-
|
|
|
-PROCEDURE RealOperand (r : ERes ; dstOff : CARDINAL) ;
|
|
|
-(* Copy a REAL operand into a 6-byte scratch, converting an ordinal value to
|
|
|
- REAL first. RealBin and RealUnary used to call EmCopyRealTo directly; an
|
|
|
- INTEGER variable there was refused, so `E := A/B' could not compile. *)
|
|
|
-VAR tmp : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- IF r.cls = TReal THEN
|
|
|
- EmCopyRealTo (dstOff, r)
|
|
|
- ELSIF (r.cls = TSet) OR (r.cls = TString) THEN
|
|
|
- Err (ETypeErr)
|
|
|
- ELSE
|
|
|
- IF r.kind = 5 THEN
|
|
|
- EmPushDi ()
|
|
|
- ELSIF r.kind = 1 THEN
|
|
|
- EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
|
|
|
- ELSE
|
|
|
- LoadAtom (r) ;
|
|
|
- EmStoreVar (FALSE, symtab [tmpA].off, 2) ;
|
|
|
- EmPushVarAddr (FALSE, symtab [tmpA].off)
|
|
|
- END ;
|
|
|
- EmPushVarAddr (FALSE, dstOff) ;
|
|
|
- DropC (EmCall (TU_RealFromInt)) ;
|
|
|
- EmAddSp (4)
|
|
|
- END
|
|
|
-END RealOperand ;
|
|
|
-
|
|
|
-PROCEDURE RealBin (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ;
|
|
|
-(* REAL + - * / using the runtime's 12-byte block entries. SaveLeft has
|
|
|
- already copied a REAL left operand to a stable scratch; a kind-5 right is
|
|
|
- copied first, while its DI address is live. *)
|
|
|
-VAR block, ent : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- block := NewScratchRealBlock () ;
|
|
|
- IF right.kind = 5 THEN
|
|
|
- RealOperand (right, symtab [block].off + 6) ;
|
|
|
- RealOperand (left, symtab [block].off)
|
|
|
- ELSE
|
|
|
- RealOperand (left, symtab [block].off) ;
|
|
|
- RealOperand (right, symtab [block].off + 6)
|
|
|
- END ;
|
|
|
- CASE op OF
|
|
|
- OpAdd : ent := TU_RealAdd
|
|
|
- | OpSub : ent := TU_RealSub
|
|
|
- | OpMul : ent := TU_RealMul
|
|
|
- | OpDiv : ent := TU_RealDiv
|
|
|
- ELSE
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- EmPushVarAddr (FALSE, symtab [block].off) ;
|
|
|
- DropC (EmCall (ent)) ;
|
|
|
- EmAddSp (2) ;
|
|
|
- res.kind := 1 ;
|
|
|
- res.idx := block ;
|
|
|
- res.cls := TReal ;
|
|
|
- res.sz := 6 ;
|
|
|
- res.boff := 0
|
|
|
-END RealBin ;
|
|
|
-
|
|
|
-PROCEDURE RealUnary (ent : CARDINAL ; VAR r : ERes) ;
|
|
|
-(* A one-argument REAL builtin: copy the operand into a 12-byte block and let
|
|
|
- the runtime entry leave its result in the first six bytes. *)
|
|
|
-VAR block : CARDINAL ;
|
|
|
-BEGIN
|
|
|
- block := NewScratchRealBlock () ;
|
|
|
- EmCopyRealTo (symtab [block].off, r) ;
|
|
|
- EmPushVarAddr (FALSE, symtab [block].off) ;
|
|
|
- DropC (EmCall (ent)) ;
|
|
|
- EmAddSp (2) ;
|
|
|
- r.kind := 1 ;
|
|
|
- r.idx := block ;
|
|
|
- r.cls := TReal ;
|
|
|
- r.sz := 6 ;
|
|
|
- r.boff := 0
|
|
|
-END RealUnary ;
|
|
|
-
|
|
|
-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 := <string literal>. 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 := <string variable>. 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 IoCall (idx : CARDINAL) ;
|
|
|
-(* WRITE / WRITELN / READ / READLN / HALT.
|
|
|
-
|
|
|
- TP3 (TPSRC8 pwriteln, pwrloop, prdtyped) does not pass a descriptor to
|
|
|
- the runtime: it looks at each argument's class and emits a *different*
|
|
|
- call per type, so the formatting is fixed at compile time. Mirrored
|
|
|
- here - one call per argument, then a final call for the line break.
|
|
|
-
|
|
|
- WRITE/WRITELN push the value; READ/READLN push the address, so the
|
|
|
- runtime can store. As everywhere else in this compiler the caller
|
|
|
- cleans the argument off the stack. *)
|
|
|
-VAR arg : ERes ;
|
|
|
- nArgs, ent, which, acls : CARDINAL ;
|
|
|
- argBytes : CARDINAL ; (* bytes pushed for this argument: 2, or 4 with
|
|
|
- a field width *)
|
|
|
- reading : BOOLEAN ;
|
|
|
- pushed : BOOLEAN ;
|
|
|
- skipArg, handled : BOOLEAN ;
|
|
|
- k, n, p, scratch, cap : CARDINAL ;
|
|
|
- dummy, errV : ERes ;
|
|
|
-BEGIN
|
|
|
- which := symtab [idx].cls ; (* BI_* *)
|
|
|
- IF which = BI_Halt THEN
|
|
|
- IF MatchDelim ('(') THEN (* halt(0) - code ignored *)
|
|
|
- ParseExpr (dummy) ;
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- END ;
|
|
|
- DropC (EmCall (TU_Halt)) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_New THEN
|
|
|
- (* New(P): allocate sizeof(P^) bytes and store the address in P. The
|
|
|
- pointer symbol's `elem' is the pointee TYPE symbol; its size is the
|
|
|
- allocation. *)
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF OK () AND ((arg.kind = 1) OR (arg.kind = 5)) AND
|
|
|
- (arg.cls = TPtr) THEN
|
|
|
- p := arg.ptrElem ;
|
|
|
- IF p = 0 THEN
|
|
|
- p := symtab [arg.idx].elem
|
|
|
- END ;
|
|
|
- EmMovAxi (symtab [p].size) ;
|
|
|
- EmPushAx () ; (* size -> [BP+6] *)
|
|
|
- IF arg.kind = 5 THEN
|
|
|
- EmPushDi () (* element pointer slot *)
|
|
|
- ELSE
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H)
|
|
|
- END ;
|
|
|
- DropC (EmCall (TU_HeapNew)) ;
|
|
|
- EmAddSp (4)
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- ELSE
|
|
|
- Err (ENoSemi)
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Dispose THEN
|
|
|
- (* Dispose(P): consume the argument. The allocator is a bump pointer
|
|
|
- with no free list; CALC allocates once at the start of Help and
|
|
|
- disposes only after the help display is finished, so not reclaiming
|
|
|
- the block has no observable effect. A future allocation after a
|
|
|
- Dispose would need a real free list. *)
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF OK () AND NOT (((arg.kind = 1) OR (arg.kind = 5))
|
|
|
- AND (arg.cls = TPtr)) THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- ELSE
|
|
|
- Err (ENoSemi)
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_ClrScr THEN
|
|
|
- EmCrtSeq (CrtClr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_ClrEol THEN
|
|
|
- (* clear from the cursor to the end of the line - a real INT 10h call,
|
|
|
- not a no-op: AH=03 reads the cursor, CX := it, DL := 79, AH=06 blanks
|
|
|
- that window. *)
|
|
|
- EmCrtSeq (CrtEol) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_GotoXY THEN
|
|
|
- (* GotoXY (x, y): 1-based; evaluate x first and park it, then y, so the
|
|
|
- code for y cannot clobber DL. *)
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () THEN
|
|
|
- LoadAtom (dummy) ;
|
|
|
- EmPushAx ()
|
|
|
- END ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () THEN
|
|
|
- LoadAtom (dummy) ;
|
|
|
- EmCrtSeq (CrtDh)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- EmPopAx () ;
|
|
|
- EmCrtSeq (CrtDl) ;
|
|
|
- EmCrtSeq (CrtCaret)
|
|
|
- ELSE
|
|
|
- Err (ENoSemi)
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_LowVideo THEN
|
|
|
- (* set the attribute the CLEAR operations use to 7; see EmCrtSeq *)
|
|
|
- EmCrtSeq (CrtLow) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_NormVideo THEN
|
|
|
- EmCrtSeq (CrtNorm) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Delay THEN
|
|
|
- (* Delay(ms): a real busy loop (EmCrtSeq's CrtDelay), no INT, so it is
|
|
|
- identical under qemu and Exec86. *)
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () THEN
|
|
|
- LoadAtom (dummy) ;
|
|
|
- EmCrtSeq (CrtDelay)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- ELSE
|
|
|
- Err (ENoSemi)
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Insert THEN
|
|
|
- (* Insert(Source, Dest, Index). A CHAR source is materialised as a
|
|
|
- one-character counted string in a scratch; Dest must be a modifiable
|
|
|
- string variable/field. Stack order is source, dest, index, max, so
|
|
|
- the runtime sees max at [BP+4] and source at [BP+10]. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF OK () AND (arg.cls = TString) AND
|
|
|
- ((arg.kind = 1) OR (arg.kind = 3) OR (arg.kind = 5)) THEN
|
|
|
- EmPushStrAddr (arg)
|
|
|
- ELSIF OK () AND ((arg.cls = TChar) OR
|
|
|
- ((arg.cls = TScalar) AND arg.chr)) THEN
|
|
|
- scratch := NewScratchStr () ;
|
|
|
- LoadAtom (arg) ;
|
|
|
- EmStoreVar (FALSE, (symtab [scratch].off + 1) MOD 10000H, 1) ;
|
|
|
- EmMovAxi (1) ;
|
|
|
- EmStoreVar (FALSE, symtab [scratch].off, 1) ;
|
|
|
- EmPushVarAddr (FALSE, symtab [scratch].off)
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () AND (dummy.cls = TString) AND
|
|
|
- ((dummy.kind = 1) OR (dummy.kind = 5)) THEN
|
|
|
- EmPushStrAddr (dummy) ;
|
|
|
- cap := VarSize (dummy) - 1 ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (errV) ;
|
|
|
- IF OK () AND ((errV.cls = TScalar) OR (errV.cls = TChar)) THEN
|
|
|
- LoadAtom (errV) ; EmPushAx () ;
|
|
|
- EmMovAxi (cap) ; EmPushAx () ;
|
|
|
- DropC (EmCall (TU_StrInsert)) ;
|
|
|
- EmAddSp (8)
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Delete THEN
|
|
|
- (* Delete(S, pos, len): S must be a variable (or a DI-addressed field);
|
|
|
- the runtime mutates it in place. S's address is parked while the
|
|
|
- two integer expressions are parsed. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF OK () AND (arg.cls = TString) AND
|
|
|
- ((arg.kind = 1) OR (arg.kind = 5)) THEN
|
|
|
- EmPushStrAddr (arg) ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () AND ((dummy.cls = TScalar) OR (dummy.cls = TChar)) THEN
|
|
|
- LoadAtom (dummy) ; EmPushAx () ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (errV) ;
|
|
|
- IF OK () AND ((errV.cls = TScalar) OR (errV.cls = TChar)) THEN
|
|
|
- LoadAtom (errV) ; EmPushAx () ;
|
|
|
- EmPopAx () ; (* len *)
|
|
|
- EmPopBx () ; (* pos *)
|
|
|
- EmPopCx () ; (* source *)
|
|
|
- EmPushAx () ; EmPushBx () ; EmPushCx () ;
|
|
|
- DropC (EmCall (TU_StrDelete)) ;
|
|
|
- EmAddSp (6)
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Val THEN
|
|
|
- (* Val(S, V, E): integer conversion. E receives 0 on success or the
|
|
|
- 1-based position of the first invalid character; V is left unchanged
|
|
|
- on error. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF OK () AND (arg.cls = TString) AND
|
|
|
- ((arg.kind = 1) OR (arg.kind = 3) OR (arg.kind = 5)) THEN
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (errV) ;
|
|
|
- IF OK () AND (dummy.kind = 1) AND (dummy.cls = TScalar)
|
|
|
- AND (VarSize (dummy) = 2) AND (errV.kind = 1)
|
|
|
- AND (errV.cls = TScalar) AND (VarSize (errV) = 2) THEN
|
|
|
- EmPushSymAddr (errV.idx, (symtab [errV.idx].off + errV.boff) MOD 10000H) ;
|
|
|
- EmPushSymAddr (dummy.idx, (symtab [dummy.idx].off + dummy.boff) MOD 10000H) ;
|
|
|
- EmPushStrAddr (arg) ;
|
|
|
- DropC (EmCall (TU_ValInt)) ;
|
|
|
- EmAddSp (6)
|
|
|
- ELSIF OK () AND (dummy.cls = TReal) AND
|
|
|
- ((dummy.kind = 1) OR (dummy.kind = 5)) AND
|
|
|
- (errV.kind = 1) AND (errV.cls = TScalar) AND (VarSize (errV) = 2)
|
|
|
- THEN
|
|
|
- EmPushSymAddr (errV.idx, (symtab [errV.idx].off + errV.boff) MOD 10000H) ;
|
|
|
- EmPushRealAddr (dummy) ;
|
|
|
- EmPushStrAddr (arg) ;
|
|
|
- DropC (EmCall (TU_ValReal)) ;
|
|
|
- EmAddSp (6)
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Str THEN
|
|
|
- (* Str(Value[:FW[:DEC]], S): format a REAL into a string variable.
|
|
|
- The source address is pushed first and parked on the stack while the
|
|
|
- width/decimals expressions and the destination are parsed; the two
|
|
|
- stack words are then swapped to real_fmt's order (source at [BP+4],
|
|
|
- destination at [BP+6]). CX carries (decimals << 8) | width; it is
|
|
|
- parked in tmpA across the destination parse, which may clobber CX.
|
|
|
- Defaults match TPSRC8 pstdef1/pstdef3: width 18, decimals FFFFh. *)
|
|
|
- IF NOT MatchDelim ('(') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF OK () AND (arg.cls = TScalar) THEN
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- ParseExpr (errV) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadAtom (arg) ; EmPushAx () ;
|
|
|
- LoadAtom (errV) ; EmPushAx () ;
|
|
|
- IF NOT MatchDelim (',') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () AND (dummy.cls = TString) AND
|
|
|
- ((dummy.kind = 1) OR (dummy.kind = 5)) THEN
|
|
|
- EmPushStrAddr (dummy) ;
|
|
|
- DropC (EmCall (TU_IntFmtW)) ;
|
|
|
- EmAddSp (6)
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadAtom (arg) ;
|
|
|
- EmPushAx () ; (* value at [BP+6] *)
|
|
|
- IF NOT MatchDelim (',') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () AND (dummy.cls = TString) AND
|
|
|
- ((dummy.kind = 1) OR (dummy.kind = 5)) THEN
|
|
|
- EmPushStrAddr (dummy) ; (* destination at [BP+4] *)
|
|
|
- DropC (EmCall (TU_IntFmt)) ;
|
|
|
- EmAddSp (4)
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF OK () AND (arg.cls = TReal) AND
|
|
|
- ((arg.kind = 1) OR (arg.kind = 5)) THEN
|
|
|
- IF arg.kind = 5 THEN
|
|
|
- EmPushDi ()
|
|
|
- ELSE
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H)
|
|
|
- END ;
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () THEN
|
|
|
- LoadAtom (dummy)
|
|
|
- END ;
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- EmPushAx () ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () THEN
|
|
|
- LoadAtom (dummy) ;
|
|
|
- EmMovChAl () ;
|
|
|
- EmPopAx () ;
|
|
|
- EmMovClAl ()
|
|
|
- END
|
|
|
- ELSIF OK () THEN
|
|
|
- EmMovClAl () ;
|
|
|
- EmMovChImm (0FFH)
|
|
|
- END
|
|
|
- ELSE
|
|
|
- EmMovCxi (0FF12H) (* width 18, decimals FFFFh *)
|
|
|
- END ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- EmMovAxCx () ;
|
|
|
- EmStoreVar (FALSE, symtab [tmpA].off, 2) ;
|
|
|
- IF NOT MatchDelim (',') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () AND (dummy.cls = TString) AND
|
|
|
- ((dummy.kind = 1) OR (dummy.kind = 5)) THEN
|
|
|
- EmPushStrAddr (dummy) ;
|
|
|
- EmPopAx () ; (* destination *)
|
|
|
- EmPopBx () ; (* source *)
|
|
|
- EmPushAx () ; (* destination at [BP+6] *)
|
|
|
- EmPushBx () ; (* source at [BP+4] *)
|
|
|
- EmLoadVar (FALSE, symtab [tmpA].off, 2) ;
|
|
|
- EmXchgAxCx () ; (* CX := packed width/decimals *)
|
|
|
- DropC (EmCall (TU_RealFmt)) ;
|
|
|
- EmAddSp (4)
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Randomize THEN
|
|
|
- DropC (EmCall (TU_Randomize)) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_FillChar THEN
|
|
|
- IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF NOT OK () OR ((arg.kind # 1) AND (arg.kind # 5)) THEN
|
|
|
- Err (ETypeErr) ; RETURN
|
|
|
- END ;
|
|
|
- IF arg.kind = 5 THEN EmPushDi () ELSE
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H)
|
|
|
- END ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN RETURN END ;
|
|
|
- LoadAtom (dummy) ; EmPushAx () ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN RETURN END ;
|
|
|
- LoadAtom (dummy) ; EmPushAx () ;
|
|
|
- EmPopAx () ; EmPopBx () ; EmPopCx () ;
|
|
|
- EmPushAx () ; EmPushBx () ; EmPushCx () ;
|
|
|
- DropC (EmCall (TU_FillChar)) ; EmAddSp (6) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Move THEN
|
|
|
- IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF NOT OK () OR ((arg.kind # 1) AND (arg.kind # 5)) THEN Err (ETypeErr) ; RETURN END ;
|
|
|
- IF arg.kind = 5 THEN EmPushDi () ELSE EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) END ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () OR ((dummy.kind # 1) AND (dummy.kind # 5)) THEN Err (ETypeErr) ; RETURN END ;
|
|
|
- IF dummy.kind = 5 THEN EmPushDi () ELSE EmPushSymAddr (dummy.idx, (symtab [dummy.idx].off + dummy.boff) MOD 10000H) END ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN RETURN END ;
|
|
|
- LoadAtom (dummy) ; EmPushAx () ;
|
|
|
- EmPopAx () ; EmPopBx () ; EmPopCx () ;
|
|
|
- EmPushAx () ; EmPushBx () ; EmPushCx () ;
|
|
|
- DropC (EmCall (TU_Move)) ; EmAddSp (6) ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Seek THEN
|
|
|
- IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF NOT OK () OR (arg.kind # 1) OR ((arg.cls # TFile) AND (arg.cls # TText) AND (arg.cls # TUntyp)) THEN
|
|
|
- Err (ETypeErr) ; RETURN
|
|
|
- END ;
|
|
|
- p := symtab [arg.idx].elem ; IF p = 0 THEN p := 1 END ;
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN RETURN END ;
|
|
|
- LoadAtom (dummy) ; EmPushAx () ;
|
|
|
- EmPopAx () ; EmPopBx () ;
|
|
|
- EmMovCxi (p) ; EmPushCx () ; EmPushAx () ; EmPushBx () ;
|
|
|
- DropC (EmCall (TU_Seek)) ; EmAddSp (6) ;
|
|
|
- ExpectDelim (')', ENoSemi) ; RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Erase THEN
|
|
|
- IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF NOT OK () OR (arg.kind # 1) OR ((arg.cls # TFile) AND (arg.cls # TText) AND (arg.cls # TUntyp)) THEN
|
|
|
- Err (ETypeErr) ; RETURN
|
|
|
- END ;
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- DropC (EmCall (TU_Erase)) ; EmAddSp (2) ;
|
|
|
- ExpectDelim (')', ENoSemi) ; RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Rename THEN
|
|
|
- IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF NOT OK () OR (arg.kind # 1) OR ((arg.cls # TFile) AND (arg.cls # TText) AND (arg.cls # TUntyp)) THEN
|
|
|
- Err (ETypeErr) ; RETURN
|
|
|
- END ;
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () OR (dummy.cls # TString) THEN Err (ETypeErr) ; RETURN END ;
|
|
|
- EmPushStrAddr (dummy) ;
|
|
|
- EmPopAx () ; EmPopBx () ; EmPushAx () ; EmPushBx () ;
|
|
|
- DropC (EmCall (TU_Rename)) ; EmAddSp (4) ;
|
|
|
- ExpectDelim (')', ENoSemi) ; RETURN
|
|
|
- END ;
|
|
|
- IF (which = BI_BlockRead) OR (which = BI_BlockWrite) THEN
|
|
|
- IF NOT MatchDelim ('(') THEN Err (ENoSemi) ; RETURN END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF NOT OK () OR (arg.kind # 1) OR ((arg.cls # TFile) AND (arg.cls # TText) AND (arg.cls # TUntyp)) THEN
|
|
|
- Err (ETypeErr) ; RETURN
|
|
|
- END ;
|
|
|
- p := symtab [arg.idx].elem ; IF p = 0 THEN p := 1 END ;
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () OR ((dummy.kind # 1) AND (dummy.kind # 5)) THEN Err (ETypeErr) ; RETURN END ;
|
|
|
- IF dummy.kind = 5 THEN EmPushDi () ELSE EmPushSymAddr (dummy.idx, (symtab [dummy.idx].off + dummy.boff) MOD 10000H) END ;
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN RETURN END ;
|
|
|
- LoadAtom (dummy) ; EmPushAx () ;
|
|
|
- IF MatchDelim (',') THEN
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () OR ((dummy.kind # 1) AND (dummy.kind # 5)) THEN Err (ETypeErr) ; RETURN END ;
|
|
|
- IF dummy.kind = 5 THEN EmPushDi () ELSE
|
|
|
- EmPushSymAddr (dummy.idx, (symtab [dummy.idx].off + dummy.boff) MOD 10000H)
|
|
|
- END
|
|
|
- ELSE
|
|
|
- EmMovAxi (0) ; EmPushAx ()
|
|
|
- END ;
|
|
|
- EmPopDx () ; EmPopAx () ; EmPopBx () ; EmPopCx () ;
|
|
|
- EmStoreVar (FALSE, symtab [tmpB].off, 2) ;
|
|
|
- EmPushDx () ; EmMovAxi (p) ; EmPushAx () ;
|
|
|
- EmLoadVar (FALSE, symtab [tmpB].off, 2) ; EmPushAx () ;
|
|
|
- EmPushBx () ; EmPushCx () ;
|
|
|
- IF which = BI_BlockRead THEN DropC (EmCall (TU_BlockRead)) ELSE DropC (EmCall (TU_BlockWrite)) END ;
|
|
|
- EmAddSp (10) ;
|
|
|
- ExpectDelim (')', ENoSemi) ; RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_GetDir THEN
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF OK () AND ((arg.cls = TScalar) OR (arg.cls = TChar)) THEN
|
|
|
- LoadAtom (arg) ;
|
|
|
- EmPushAx () ; (* drive *)
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () AND (dummy.cls = TString) AND (dummy.kind = 1) THEN
|
|
|
- EmPushSymAddr (dummy.idx, (symtab [dummy.idx].off + dummy.boff) MOD 10000H) ;
|
|
|
- DropC (EmCall (TU_GetDir)) ;
|
|
|
- EmAddSp (4)
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- ELSE
|
|
|
- Err (ENoSemi)
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF (which = BI_Msdos) OR (which = BI_Intr) THEN
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- IF which = BI_Intr THEN
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () AND NOT ((dummy.kind = 0) AND (W16 (dummy.imm) = 21H)) THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ExpectDelim (',', ENoSemi)
|
|
|
- END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF OK () AND (arg.kind = 1) AND (arg.cls = TRecord) THEN
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- DropC (EmCall (TU_Msdos)) ;
|
|
|
- EmAddSp (2)
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- ELSE
|
|
|
- Err (ENoSemi)
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_Assign THEN
|
|
|
- (* Assign(F, Name): the file variable's address and the counted
|
|
|
- string's address. The runtime copies the characters into the file
|
|
|
- control block and marks it closed; Reset/Rewrite do the DOS open.
|
|
|
- Name is pushed first, so the runtime sees F at [BP+4] and Name at
|
|
|
- [BP+6]. *)
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF OK () AND (arg.kind = 1) AND
|
|
|
- ((arg.cls = TFile) OR (arg.cls = TText) OR (arg.cls = TUntyp)) THEN
|
|
|
- ExpectDelim (',', ENoSemi) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF OK () THEN
|
|
|
- IF dummy.cls = TString THEN
|
|
|
- EmPushStrAddr (dummy) ;
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- DropC (EmCall (TU_FileAssign)) ;
|
|
|
- EmAddSp (4)
|
|
|
- ELSE
|
|
|
- Err (ETypeErr)
|
|
|
- END
|
|
|
- END
|
|
|
- ELSIF OK () THEN
|
|
|
- Err (ETypeErr)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- ELSE
|
|
|
- Err (ENoSemi)
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF (which = BI_Reset) OR (which = BI_Rewrite) OR (which = BI_Close) THEN
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF OK () THEN
|
|
|
- IF (arg.kind = 1) AND
|
|
|
- ((arg.cls = TFile) OR (arg.cls = TText) OR (arg.cls = TUntyp)) THEN
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- IF which = BI_Reset THEN
|
|
|
- DropC (EmCall (TU_FileReset))
|
|
|
- ELSIF which = BI_Rewrite THEN
|
|
|
- DropC (EmCall (TU_FileRewrite))
|
|
|
- ELSE
|
|
|
- DropC (EmCall (TU_FileClose))
|
|
|
- END ;
|
|
|
- EmAddSp (2)
|
|
|
- ELSE
|
|
|
- Err (ETypeErr)
|
|
|
- END
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi)
|
|
|
- ELSE
|
|
|
- Err (ENoSemi)
|
|
|
- END ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- reading := (which = BI_Read) OR (which = BI_ReadLn) ;
|
|
|
- nArgs := 0 ;
|
|
|
- IF MatchDelim ('(') THEN
|
|
|
- IF CurCh () # ')' THEN
|
|
|
- LOOP
|
|
|
- IF nArgs >= 16 THEN
|
|
|
- Err (ECompOvf) ;
|
|
|
- EXIT
|
|
|
- END ;
|
|
|
- ParseExpr (arg) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- (* An argument that did not type-check has no value and arg.idx
|
|
|
- is not a symbol. The string arm below dereferences
|
|
|
- symtab[arg.idx] for ANY value whose class is TString - unlike
|
|
|
- the string assign in Assignment, which can tell a failed
|
|
|
- concat from a real one by its kind - so a `writeln' of a
|
|
|
- rejected expression read symtab with whatever idx held
|
|
|
- before and dereferenced it. That is exactly how
|
|
|
- `writeln('a' + 'b')' - two CHARs, a type error since
|
|
|
- v-TP3-STRCAT - segfaulted the compiler instead of reporting
|
|
|
- the error. ParseSub guards its subscript the same way (see
|
|
|
- `IF OK () THEN' before symtab[r.idx] there), and the
|
|
|
- statement loop stops at the next iteration, so leaving the
|
|
|
- rest of this WRITELN unparsed is harmless. *)
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- (* One argument at a time: parse it, give it its own push or its
|
|
|
- own runtime call, and only then read the next one. TPSRC8
|
|
|
- pwrloop does exactly this, and it has to - a computed argument
|
|
|
- exists only in AX, so parsing the argument after it, and the
|
|
|
- call made for THIS one, are both free to destroy it. Reading
|
|
|
- the whole list first and emitting afterwards printed the first
|
|
|
- argument as the last argument's value, and pushed an argument
|
|
|
- that an earlier inline string's call had already overwritten. *)
|
|
|
- skipArg := FALSE ;
|
|
|
- handled := FALSE ;
|
|
|
- IF (nArgs = 0) AND (arg.cls = TText) THEN
|
|
|
- (* A leading TEXT file argument. KBD is the console keyboard
|
|
|
- and this runtime's read entries already read the console, so
|
|
|
- the file is dropped and the rest of the argument list is read
|
|
|
- exactly as without it. *)
|
|
|
- IF reading AND (arg.kind = 1) AND symtab [arg.idx].isKbd THEN
|
|
|
- IF NOT MatchDelim (',') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- skipArg := TRUE
|
|
|
- ELSIF reading THEN
|
|
|
- (* Text-file reads. A number is read as a whitespace-
|
|
|
- delimited token and handed to ValInt/ValReal; a string
|
|
|
- still uses the line reader. Readln consumes the rest
|
|
|
- of the line after all numeric arguments. *)
|
|
|
- IF NOT MatchDelim (',') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LOOP
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF dummy.cls = TString THEN
|
|
|
- IF (dummy.kind = 1) OR (dummy.kind = 5) THEN
|
|
|
- EmMovAxi ((VarSize (dummy) - 1) MOD 10000H) ;
|
|
|
- EmPushAx () ;
|
|
|
- EmPushStrAddr (dummy) ;
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- DropC (EmCall (TU_FileReadln)) ;
|
|
|
- EmAddSp (6)
|
|
|
- ELSE
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- ELSIF IsCharArray (dummy) AND (dummy.kind = 1) THEN
|
|
|
- scratch := NewScratchStr () ;
|
|
|
- k := 1 ;
|
|
|
- WHILE k <= VarSize (dummy) DO
|
|
|
- EmMovAxi (ORD (' ')) ;
|
|
|
- EmStoreVar (FALSE, (symtab [scratch].off + k) MOD 10000H, 1) ;
|
|
|
- INC (k)
|
|
|
- END ;
|
|
|
- EmMovAxi (VarSize (dummy)) ;
|
|
|
- EmPushAx () ;
|
|
|
- EmPushVarAddr (FALSE, symtab [scratch].off) ;
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- DropC (EmCall (TU_FileReadln)) ;
|
|
|
- EmAddSp (6) ;
|
|
|
- EmPushVarAddr (FALSE, (symtab [scratch].off + 1) MOD 10000H) ;
|
|
|
- EmPushSymAddr (dummy.idx, (symtab [dummy.idx].off + dummy.boff) MOD 10000H) ;
|
|
|
- EmMovCxi (VarSize (dummy)) ;
|
|
|
- DropC (EmCall (TU_MemCopy)) ;
|
|
|
- EmAddSp (4)
|
|
|
- ELSIF (dummy.kind = 1) AND
|
|
|
- ((dummy.cls = TScalar) OR (dummy.cls = TReal)) THEN
|
|
|
- scratch := NewScratchStr () ;
|
|
|
- EmPushVarAddr (FALSE, symtab [scratch].off) ;
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- DropC (EmCall (TU_FileRdtok)) ;
|
|
|
- EmAddSp (4) ;
|
|
|
- EmPushVarAddr (FALSE, symtab [tmpA].off) ;
|
|
|
- EmPushSymAddr (dummy.idx, (symtab [dummy.idx].off + dummy.boff) MOD 10000H) ;
|
|
|
- EmPushVarAddr (FALSE, symtab [scratch].off) ;
|
|
|
- IF dummy.cls = TReal THEN
|
|
|
- DropC (EmCall (TU_ValReal))
|
|
|
- ELSE
|
|
|
- DropC (EmCall (TU_ValInt))
|
|
|
- END ;
|
|
|
- EmAddSp (6)
|
|
|
- ELSE
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF NOT MatchDelim (',') THEN
|
|
|
- EXIT
|
|
|
- END
|
|
|
- END ;
|
|
|
- IF which = BI_ReadLn THEN
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- DropC (EmCall (TU_FileRdln)) ;
|
|
|
- EmAddSp (2)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- ELSE
|
|
|
- (* Text-file output: Writeln(File) is CRLF, Write(File, C)
|
|
|
- is one CHAR, and writeln(File, S) is S followed by CRLF.
|
|
|
- Write each byte range with DOS AH=40h; a string argument
|
|
|
- carries its own length byte, a one-CHAR literal becomes a
|
|
|
- tiny code-resident <1><char>. *)
|
|
|
- IF (arg.kind # 1) OR (symtab [arg.idx].cls # TText) THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF MatchDelim (',') THEN
|
|
|
- LOOP
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF dummy.cls = TString THEN
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- ParseExpr (errV) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadAtom (errV) ;
|
|
|
- EmPushAx () ; (* width *)
|
|
|
- EmPushStrAddr (dummy) ; (* source *)
|
|
|
- scratch := NewScratchStr () ;
|
|
|
- EmPushVarAddr (FALSE, symtab [scratch].off) ;
|
|
|
- DropC (EmCall (TU_StrFmtW)) ;
|
|
|
- EmAddSp (6) ;
|
|
|
- EmFileIo (FALSE, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 1, FALSE,
|
|
|
- symtab [scratch].off, 0, TRUE)
|
|
|
- ELSIF dummy.kind = 1 THEN
|
|
|
- EmFileIo (FALSE, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 1,
|
|
|
- symtab [dummy.idx].local,
|
|
|
- (symtab [dummy.idx].off + dummy.boff)
|
|
|
- MOD 10000H,
|
|
|
- 0, TRUE)
|
|
|
- ELSIF dummy.kind = 5 THEN
|
|
|
- EmFileIo (FALSE, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 5, FALSE,
|
|
|
- 0, 0, TRUE)
|
|
|
- ELSIF dummy.kind = 3 THEN
|
|
|
- EmFileIo (FALSE, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 4, FALSE,
|
|
|
- EmStrBlob (dummy), 0, TRUE)
|
|
|
- ELSE
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- ELSIF (dummy.cls = TChar) OR
|
|
|
- ((dummy.cls = TScalar) AND dummy.chr) THEN
|
|
|
- IF dummy.kind = 1 THEN
|
|
|
- EmFileIo (FALSE, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 1,
|
|
|
- symtab [dummy.idx].local,
|
|
|
- (symtab [dummy.idx].off + dummy.boff)
|
|
|
- MOD 10000H,
|
|
|
- 1, FALSE)
|
|
|
- ELSIF dummy.kind = 5 THEN
|
|
|
- EmFileIo (FALSE, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 5, FALSE,
|
|
|
- 0, 1, FALSE)
|
|
|
- ELSIF dummy.kind = 2 THEN
|
|
|
- EmStoreVar (FALSE, symtab [tmpA].off, 1) ;
|
|
|
- EmFileIo (FALSE, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 1, FALSE,
|
|
|
- symtab [tmpA].off, 1, FALSE)
|
|
|
- ELSIF dummy.kind = 0 THEN
|
|
|
- EmFileIo (FALSE, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 4, FALSE,
|
|
|
- EmInlineCh (VAL (CARDINAL, dummy.imm)),
|
|
|
- 0, TRUE)
|
|
|
- ELSE
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- ELSIF dummy.cls = TReal THEN
|
|
|
- EmPushRealAddr (dummy) ;
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- ParseExpr (errV) ;
|
|
|
- IF OK () THEN LoadAtom (errV) END ;
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- EmPushAx () ;
|
|
|
- ParseExpr (errV) ;
|
|
|
- IF OK () THEN
|
|
|
- LoadAtom (errV) ;
|
|
|
- EmMovChAl () ;
|
|
|
- EmPopAx () ;
|
|
|
- EmMovClAl ()
|
|
|
- END
|
|
|
- ELSIF OK () THEN
|
|
|
- EmMovClAl () ;
|
|
|
- EmMovChImm (0FFH)
|
|
|
- END
|
|
|
- ELSE
|
|
|
- EmMovCxi (0FF12H)
|
|
|
- END ;
|
|
|
- EmMovAxCx () ;
|
|
|
- EmStoreVar (FALSE, symtab [tmpA].off, 2) ;
|
|
|
- scratch := NewScratchStr () ;
|
|
|
- EmPushVarAddr (FALSE, symtab [scratch].off) ;
|
|
|
- EmPopAx () ;
|
|
|
- EmPopBx () ;
|
|
|
- EmPushAx () ;
|
|
|
- EmPushBx () ;
|
|
|
- EmLoadVar (FALSE, symtab [tmpA].off, 2) ;
|
|
|
- EmXchgAxCx () ;
|
|
|
- DropC (EmCall (TU_RealFmt)) ;
|
|
|
- EmAddSp (4) ;
|
|
|
- EmFileIo (FALSE, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 1, FALSE,
|
|
|
- symtab [scratch].off, 0, TRUE)
|
|
|
- ELSIF dummy.cls = TScalar THEN
|
|
|
- (* integer with the optional TP3 `:width' *)
|
|
|
- LoadAtom (dummy) ;
|
|
|
- EmPushAx () ;
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- ParseExpr (errV) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadAtom (errV) ;
|
|
|
- EmPushAx ()
|
|
|
- ELSE
|
|
|
- EmMovAxi (0) ;
|
|
|
- EmPushAx ()
|
|
|
- END ;
|
|
|
- scratch := NewScratchStr () ;
|
|
|
- EmPushVarAddr (FALSE, symtab [scratch].off) ;
|
|
|
- DropC (EmCall (TU_IntFmtW)) ;
|
|
|
- EmAddSp (6) ;
|
|
|
- EmFileIo (FALSE, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 1, FALSE,
|
|
|
- symtab [scratch].off, 0, TRUE)
|
|
|
- ELSE
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF NOT MatchDelim (',') THEN
|
|
|
- EXIT
|
|
|
- END
|
|
|
- END
|
|
|
- END ;
|
|
|
- IF which = BI_WriteLn THEN
|
|
|
- EmFileIo (FALSE, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 4, FALSE,
|
|
|
- EmInlineCrLf (), 0, TRUE)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- ELSIF (nArgs = 0) AND (arg.cls = TFile) THEN
|
|
|
- (* Typed-file block I/O: `write(MCfile, Sheet[I,J])' and the
|
|
|
- symmetric `read(MCfile, Sheet[FX,FY])'. TP3 moves exactly
|
|
|
- one element per call, so consume the single data argument
|
|
|
- here and emit the DOS block call. The element size comes
|
|
|
- from the data expression and must agree with the file's
|
|
|
- declared element size; a mismatch is a type error, not a
|
|
|
- reason to write the wrong number of bytes. *)
|
|
|
- IF (arg.kind # 1) OR NOT MatchDelim (',') THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF ((dummy.kind # 1) AND (dummy.kind # 5))
|
|
|
- OR (VarSize (dummy) # symtab [arg.idx].elem) THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF dummy.kind = 5 THEN
|
|
|
- EmFileIo (reading, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 5, FALSE, 0, VarSize (dummy),
|
|
|
- FALSE)
|
|
|
- ELSE
|
|
|
- EmFileIo (reading, symtab [arg.idx].local,
|
|
|
- symtab [arg.idx].off, 1, symtab [dummy.idx].local,
|
|
|
- (symtab [dummy.idx].off + dummy.boff) MOD 10000H,
|
|
|
- VarSize (dummy), FALSE)
|
|
|
- END ;
|
|
|
- ExpectDelim (')', ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF NOT skipArg AND IsCharArray (arg) AND (arg.kind = 1) THEN
|
|
|
- IF reading THEN
|
|
|
- (* Readln(Place): read through a temporary counted string,
|
|
|
- then copy its fixed-width bytes over the char array.
|
|
|
- The temporary is pre-filled with spaces so a short line
|
|
|
- leaves the array padded, and rdstr leaves the newline
|
|
|
- pending for the Readln wrapper. *)
|
|
|
- scratch := NewScratchStr () ;
|
|
|
- k := 1 ;
|
|
|
- WHILE k <= VarSize (arg) DO
|
|
|
- EmMovAxi (ORD (' ')) ;
|
|
|
- EmStoreVar (FALSE, (symtab [scratch].off + k) MOD 10000H, 1) ;
|
|
|
- INC (k)
|
|
|
- END ;
|
|
|
- EmPushVarAddr (FALSE, symtab [scratch].off) ;
|
|
|
- EmMovCxi (VarSize (arg)) ;
|
|
|
- DropC (EmCall (TU_RdStr)) ;
|
|
|
- EmAddSp (2) ;
|
|
|
- EmPushVarAddr (FALSE, (symtab [scratch].off + 1) MOD 10000H) ;
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
|
|
|
- EmMovCxi (VarSize (arg)) ;
|
|
|
- DropC (EmCall (TU_MemCopy)) ;
|
|
|
- EmAddSp (4)
|
|
|
- ELSE
|
|
|
- (* Write a fixed char array one byte at a time. *)
|
|
|
- k := 0 ;
|
|
|
- WHILE k < VarSize (arg) DO
|
|
|
- LoadSymVar (arg.idx, (symtab [arg.idx].off + arg.boff + k) MOD 10000H, 1) ;
|
|
|
- EmMovAh0 () ;
|
|
|
- EmPushAx () ;
|
|
|
- DropC (EmCall (TU_WrChar)) ;
|
|
|
- EmAddSp (2) ;
|
|
|
- INC (k)
|
|
|
- END
|
|
|
- END ;
|
|
|
- handled := TRUE
|
|
|
- END ;
|
|
|
- IF NOT skipArg AND NOT handled THEN
|
|
|
- pushed := TRUE ; (* default: value is on the stack -> call + pop *)
|
|
|
- argBytes := 2 ;
|
|
|
- IF reading THEN
|
|
|
- IF (arg.kind # 1) AND (arg.kind # 5) THEN
|
|
|
- Err (ETypeErr) ; (* READ needs a variable *)
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF arg.kind = 5 THEN
|
|
|
- (* A DI-addressed element: its TYPE is on the expression
|
|
|
- (WithLookup/ParseSub set it), because the symbol is the
|
|
|
- containing array/record. s[i] is TChar; a WITH string
|
|
|
- field is TString. *)
|
|
|
- acls := arg.cls
|
|
|
- ELSE
|
|
|
- acls := symtab [arg.idx].cls ;
|
|
|
- (* s[i] is a CHAR variable, so read(s[i]) must read one byte
|
|
|
- at off+boff, not the whole string at off. arg.cls is
|
|
|
- TChar (set by ParseSub) while the symbol's own class is
|
|
|
- still TString, which is exactly how the element is told
|
|
|
- from the whole string; the address push has to carry boff.
|
|
|
- For a plain variable arg.boff is 0, so nothing changes. *)
|
|
|
- IF (acls = TString) AND (arg.cls = TChar) THEN
|
|
|
- acls := TChar
|
|
|
- END
|
|
|
- END ;
|
|
|
- IF arg.kind = 5 THEN
|
|
|
- (* A variable index: ParseSub computed the element's address
|
|
|
- into DI, and nothing has been emitted since, so that is
|
|
|
- the address READ wants. A constant index folds into boff
|
|
|
- and takes the LEA path below. *)
|
|
|
- EmPushDi ()
|
|
|
- ELSIF symtab [arg.idx].isVar THEN
|
|
|
- (* A VAR parameter: its slot holds the address READ must
|
|
|
- store through, not the address of the slot. *)
|
|
|
- IF arg.boff # 0 THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadSymVar (arg.idx, symtab [arg.idx].off, 2) ;
|
|
|
- EmPushAx ()
|
|
|
- ELSE
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H)
|
|
|
- END ;
|
|
|
- IF acls = TString THEN
|
|
|
- (* readln(s)/read(s) of a string variable: TPSRC8 prdstr
|
|
|
- pushes the address, emits MOV CL,max_len and CALL
|
|
|
- xrdstr. Here the limit is a full MOV CX,imm16 (this
|
|
|
- runtime has no byte-register CH/CL setup), and rdstr
|
|
|
- leaves the terminator pending so the readln wrapper can
|
|
|
- consume the newline. *)
|
|
|
- EmMovCxi ((VarSize (arg) - 1) MOD 10000H) ;
|
|
|
- ent := TU_RdStr
|
|
|
- ELSIF acls = TReal THEN
|
|
|
- ent := TU_RdInt (* real reads: not yet *)
|
|
|
- ELSIF acls = TBool THEN
|
|
|
- (* TP3 refuses boolean I/O: TPSRC8 prderrtp is error 66,
|
|
|
- "I/O not allowed here", and the runtime has no xrdbool
|
|
|
- at all. rdbool stores a WORD, so one byte of an
|
|
|
- accepted read would land on the variable AFTER b - the
|
|
|
- exact overflow t37_readbyte pins for a byte. TP3's
|
|
|
- answer to the whole class is the error; so is ours. *)
|
|
|
- Err (EIoHere) ;
|
|
|
- RETURN
|
|
|
- ELSIF acls = TChar THEN
|
|
|
- ent := TU_RdChar (* one byte, not a word *)
|
|
|
- ELSIF acls = TScalar THEN
|
|
|
- (* Dispatch on the SIZE, as TPSRC8 prdnum does:
|
|
|
- `CMP varsize,#$01 / JA prdemit' keeps xrdint for
|
|
|
- anything wider and falls through to `MOV AX,#xrdbyte'
|
|
|
- for a one-byte variable. A BYTE is still TScalar (it
|
|
|
- is *written* as an integer, as in TP3), but reading one
|
|
|
- through rdint stored a word - and the second byte of
|
|
|
- that word is the byte that FOLLOWS the variable. *)
|
|
|
- IF VarSize (arg) = 1 THEN
|
|
|
- ent := TU_RdByte
|
|
|
- ELSE
|
|
|
- ent := TU_RdInt
|
|
|
- END
|
|
|
- ELSE
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- ELSE
|
|
|
- acls := arg.cls ;
|
|
|
- IF (acls = TString) AND (arg.kind = 3) THEN
|
|
|
- (* An inline string literal. TP3 TPSRC8 pwrinlin special-cases a
|
|
|
- literal that is followed directly by ',' or ')' - i.e. an
|
|
|
- argument, not an expression - and emits
|
|
|
- CALL wrtinl <length byte> <characters...>
|
|
|
- with no stack argument at all; wrtinl reads the length from the
|
|
|
- return address and returns to just past the last character.
|
|
|
- A following `:width' needs the ordinary address form, so
|
|
|
- wrstrw can pad it; the no-width path keeps the compact
|
|
|
- inline byte stream. *)
|
|
|
- IF strLen [arg.strx] > 255 THEN
|
|
|
- (* The length is one byte, so a literal of 256 characters or
|
|
|
- more would wrap: 300 characters emitted behind a length of
|
|
|
- 44, and the runtime would print 44 of them and silently drop
|
|
|
- the rest. TP3 strings are at most 255 characters, so refuse
|
|
|
- rather than truncate. *)
|
|
|
- Err (EConstRange) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- (* A string literal with a field width: make its bytes an
|
|
|
- ordinary code-resident address, then pad before it. *)
|
|
|
- EmPushStrAddr (arg) ;
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadAtom (dummy) ;
|
|
|
- EmPushAx () ;
|
|
|
- ent := TU_WrStrW ;
|
|
|
- argBytes := 4
|
|
|
- ELSE
|
|
|
- DropC (EmCall (TU_WrInl)) ;
|
|
|
- Ebyte (VAL (BYTE, strLen [arg.strx])) ;
|
|
|
- n := 0 ;
|
|
|
- WHILE n < strLen [arg.strx] DO
|
|
|
- Ebyte (VAL (BYTE, ORD (strPool [strOff [arg.strx] + n]))) ;
|
|
|
- INC (n)
|
|
|
- END ;
|
|
|
- pushed := FALSE (* nothing was pushed for this one *)
|
|
|
- END
|
|
|
- ELSE
|
|
|
- IF acls = TString THEN
|
|
|
- (* A string *variable*. Its value IS its address, so it is
|
|
|
- passed exactly the way READ passes an address: push it
|
|
|
- and call the owner of the layout - wrstr - which reads
|
|
|
- the length byte and prints that many characters. TPSRC8
|
|
|
- pwrstr/pwrchk route a string argument to xwrtstr, and
|
|
|
- xwrtstr reaches its argument through BP just like WrChar
|
|
|
- does. The only difference from the inline-literal arm
|
|
|
- above is where the bytes live: a literal's are in the
|
|
|
- code stream (wrtinl) and a variable's are in the data
|
|
|
- segment or the frame (wrstr). *)
|
|
|
- (* off + boff: a string FIELD of a record/array has a
|
|
|
- non-zero boff, and the address is the field's, not the
|
|
|
- containing variable's. `writeln (g[2,3].S)' printed
|
|
|
- the empty first element before this.
|
|
|
- A DI-addressed field (`with Sheet[I,J] do
|
|
|
- Write(Contents)') already HAS its address in DI. *)
|
|
|
- IF arg.kind = 5 THEN
|
|
|
- EmPushDi ()
|
|
|
- ELSIF symtab [arg.idx].isVar THEN
|
|
|
- (* VAR string: the slot holds the address of the
|
|
|
- caller's characters; push that, not the slot. *)
|
|
|
- LoadSymVar (arg.idx, symtab [arg.idx].off, 2) ;
|
|
|
- EmPushAx ()
|
|
|
- ELSE
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H)
|
|
|
- END ;
|
|
|
- ent := TU_WrStr ;
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadAtom (dummy) ;
|
|
|
- EmPushAx () ;
|
|
|
- ent := TU_WrStrW ;
|
|
|
- argBytes := 4
|
|
|
- END
|
|
|
- ELSE
|
|
|
- IF acls = TReal THEN
|
|
|
- (* A REAL is six bytes, so the writer takes its
|
|
|
- ADDRESS, not its value: push the address first,
|
|
|
- then the width, then the decimals. The entry is
|
|
|
- real_write, with [BP+4]=decimals, [BP+6]=width and
|
|
|
- [BP+8]=real. TP3's defaults are width 18 and
|
|
|
- decimals FFFFh (its scientific mode); a width with
|
|
|
- no second colon keeps that default, which is
|
|
|
- exactly what TPSRC8 pwrdef/pwrdef3 push. *)
|
|
|
- IF arg.kind = 5 THEN
|
|
|
- EmPushDi ()
|
|
|
- ELSE
|
|
|
- EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H)
|
|
|
- END ;
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadAtom (dummy) ;
|
|
|
- EmPushAx () ;
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadAtom (dummy) ;
|
|
|
- EmPushAx ()
|
|
|
- ELSE
|
|
|
- EmMovAxi (0FFFFH) ;
|
|
|
- EmPushAx ()
|
|
|
- END
|
|
|
- ELSE
|
|
|
- EmMovAxi (18) ;
|
|
|
- EmPushAx () ;
|
|
|
- EmMovAxi (0FFFFH) ;
|
|
|
- EmPushAx ()
|
|
|
- END ;
|
|
|
- ent := TU_RealWrite ;
|
|
|
- argBytes := 6
|
|
|
- ELSE
|
|
|
- LoadAtom (arg) ;
|
|
|
- EmPushAx () ;
|
|
|
- IF arg.chr THEN
|
|
|
- ent := TU_WrChar (* 'a' - one char, not 97 *)
|
|
|
- ELSIF acls = TBool THEN
|
|
|
- ent := TU_WrBool
|
|
|
- ELSIF acls = TChar THEN
|
|
|
- ent := TU_WrChar (* c : char - one char *)
|
|
|
- ELSIF acls = TScalar THEN
|
|
|
- ent := TU_WrInt
|
|
|
- ELSE
|
|
|
- Err (ETypeErr) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- (* Field width: `writeln(I:2)'. TP3 evaluates the
|
|
|
- width (CALC passes `FW', a variable), so it is
|
|
|
- parsed and pushed AFTER the value: width at BP+4,
|
|
|
- value at BP+6. Char, BOOLEAN and integer each
|
|
|
- have their own width entry; a second colon is
|
|
|
- only legal for REAL, handled above. *)
|
|
|
- ParseExpr (dummy) ;
|
|
|
- IF NOT OK () THEN
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadAtom (dummy) ;
|
|
|
- EmPushAx () ;
|
|
|
- IF MatchDelim (':') THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF arg.chr OR (acls = TChar) THEN
|
|
|
- ent := TU_WrCharW
|
|
|
- ELSIF acls = TBool THEN
|
|
|
- ent := TU_WrBoolW
|
|
|
- ELSE
|
|
|
- ent := TU_WrIntW
|
|
|
- END ;
|
|
|
- argBytes := 4
|
|
|
- END
|
|
|
- END
|
|
|
- END
|
|
|
- END
|
|
|
- END ;
|
|
|
- IF pushed THEN
|
|
|
- DropC (EmCall (ent)) ;
|
|
|
- EmAddSp (argBytes) (* 2, or 4 with a width *)
|
|
|
- END ;
|
|
|
- INC (nArgs)
|
|
|
- END ;
|
|
|
- IF NOT skipArg THEN
|
|
|
- IF NOT MatchDelim (',') THEN
|
|
|
- EXIT
|
|
|
- END
|
|
|
- END
|
|
|
- END ;
|
|
|
- IF NOT MatchDelim (')') THEN
|
|
|
- Err (ENoSemi) ;
|
|
|
- RETURN
|
|
|
- END
|
|
|
- ELSE
|
|
|
- DropCh (GetCh ())
|
|
|
- END
|
|
|
- END ;
|
|
|
- IF reading AND (nArgs = 0) THEN
|
|
|
- (* readln with no variable: just skip to the next line *)
|
|
|
- DropC (EmCall (TU_RdLn)) ;
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- IF which = BI_WriteLn THEN
|
|
|
- DropC (EmCall (TU_WrLn))
|
|
|
- ELSIF which = BI_ReadLn THEN
|
|
|
- DropC (EmCall (TU_RdLn))
|
|
|
+ Ebyte (0B4H) ; Ebyte (02H) ; (* MOV AH,02h *)
|
|
|
+ Ebyte (0B7H) ; Ebyte (00H) ; (* MOV BH,00h *)
|
|
|
+ Ebyte (0CDH) ; Ebyte (10H) (* INT 10h *)
|
|
|
END
|
|
|
-END IoCall ;
|
|
|
+END EmCrtSeq ;
|
|
|
|
|
|
PROCEDURE LabelColonAhead () : BOOLEAN ;
|
|
|
(* `Label:' is a statement label, but `Name;' is a procedure call. Look
|
