|
|
@@ -86,19 +86,27 @@ CONST
|
|
|
TkSet = 36 ; TkPacked = 37 ; TkForward = 38 ; TkExternal = 39 ;
|
|
|
TkAbsolute = 40 ; TkOverlay = 41 ; TkString = 42 ;
|
|
|
|
|
|
- (* runtime entry offsets in the emitted image (TU_InitMem etc.) *)
|
|
|
- TU_InitMem = 8H ;
|
|
|
- TU_ProgEnd = 10H ;
|
|
|
- TU_StackChk = 18H ;
|
|
|
+ (* Runtime entry offsets in the emitted image.
|
|
|
|
|
|
- (* Standard-procedure runtime entries. TP3 does NOT pass a descriptor:
|
|
|
+ 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. *)
|
|
|
+ the runtime needs only the value. Mirrored here.
|
|
|
+
|
|
|
+ These offsets are still PLACEHOLDERS on a fixed ladder. The real
|
|
|
+ offsets are known - Runtime.RT_Entry derives them from the assembled
|
|
|
+ blob (wrtinl is really at 8EH) - but the compiler does not copy the
|
|
|
+ runtime into its code buffer yet, so it cannot call it, and using the
|
|
|
+ true offsets here would only look like it works. They all get replaced
|
|
|
+ by RT_Entry in one go when the runtime is wired in. *)
|
|
|
+ TU_InitMem = 8H ;
|
|
|
+ TU_ProgEnd = 10H ;
|
|
|
+ TU_StackChk = 18H ;
|
|
|
TU_WrInt = 20H ; TU_WrChar = 28H ; TU_WrBool = 30H ;
|
|
|
TU_WrReal = 38H ; TU_WrLn = 40H ;
|
|
|
TU_RdInt = 48H ; TU_RdChar = 50H ; TU_RdBool = 58H ;
|
|
|
TU_RdLn = 60H ; TU_Halt = 68H ;
|
|
|
+ TU_WrInl = 70H ; (* inline string literal; takes NO stack argument *)
|
|
|
|
|
|
(* TP3 error numbers *)
|
|
|
ENoSemi = 1 ; EPointExp = 10 ; ESimpType = 30 ;
|
|
|
@@ -146,11 +154,13 @@ TYPE
|
|
|
ERes =
|
|
|
RECORD
|
|
|
cls : CARDINAL ;
|
|
|
- kind : CARDINAL ; (* 0 const, 1 var, 2 value in AX *)
|
|
|
+ kind : CARDINAL ; (* 0 const, 1 var, 2 value in AX,
|
|
|
+ 3 string literal (cls = TString) *)
|
|
|
imm : LONGINT ;
|
|
|
idx : CARDINAL ;
|
|
|
boff : CARDINAL ; (* constant fold-in for subscripts *)
|
|
|
chr : BOOLEAN ; (* single-quoted literal, e.g. 'a' *)
|
|
|
+ strx : CARDINAL ; (* string literal: index into strPool *)
|
|
|
END ;
|
|
|
|
|
|
DirRec = RECORD rng, chk : BOOLEAN END ;
|
|
|
@@ -164,6 +174,22 @@ VAR
|
|
|
|
|
|
wrd : ARRAY [0..MaxName] OF CHAR ;
|
|
|
|
|
|
+ (* String-literal pool.
|
|
|
+
|
|
|
+ TP3 does not put a literal in the data segment at all: it emits the
|
|
|
+ literal *inline in the code stream* as <length byte><characters>, and
|
|
|
+ the runtime entry "wrtinl" reads the length from the return address and
|
|
|
+ returns to just past the last character (TPSRC4 xwrtinl, TPSRC10
|
|
|
+ estring). So nothing here ends up in the image as data - the pool only
|
|
|
+ has to survive from the moment the literal is scanned until IoCall
|
|
|
+ decides to emit it, because by then the parser has moved on. *)
|
|
|
+ strPool : ARRAY [0..4095] OF CHAR ;
|
|
|
+ strOff : ARRAY [0..255] OF CARDINAL ;
|
|
|
+ strLen : ARRAY [0..255] OF CARDINAL ;
|
|
|
+ strTop : CARDINAL ; (* next free byte in strPool *)
|
|
|
+ strCnt : CARDINAL ; (* literals collected so far *)
|
|
|
+ rdStrX : CARDINAL ; (* pool index of the literal RdConst just read *)
|
|
|
+
|
|
|
symtab : ARRAY [0..MaxSym - 1] OF SymEntry ;
|
|
|
symTop : CARDINAL ;
|
|
|
|
|
|
@@ -1100,10 +1126,56 @@ BEGIN
|
|
|
v := acc
|
|
|
END RdIntConst ;
|
|
|
|
|
|
+PROCEDURE StrNew (first : CARDINAL ; hasFirst : BOOLEAN ) : CARDINAL ;
|
|
|
+(* Open a pool slot for a string literal, optionally pre-seeded with its
|
|
|
+ first character.
|
|
|
+
|
|
|
+ RdConst has to read the first character before it can tell a one-character
|
|
|
+ literal from a longer one - the "is the next character another quote?"
|
|
|
+ test only makes sense once something has been read - so the seeding has to
|
|
|
+ happen here and has to advance strTop. Leaving strTop alone and letting the
|
|
|
+ caller write the character by hand is a trap: strTop is the next FREE byte,
|
|
|
+ so the first StrPut lands on top of the seeded character and overwrites it.
|
|
|
+ (That bug shipped the literal 'hi' as 69 00 - 'i' then NUL.) *)
|
|
|
+VAR x : CARDINAL ;
|
|
|
+BEGIN
|
|
|
+ IF strCnt > HIGH (strOff) THEN
|
|
|
+ Err (ECompOvf) ; (* too many literals in one unit *)
|
|
|
+ RETURN 0
|
|
|
+ END ;
|
|
|
+ x := strCnt ;
|
|
|
+ strOff [x] := strTop ;
|
|
|
+ strLen [x] := 0 ;
|
|
|
+ INC (strCnt) ;
|
|
|
+ IF hasFirst THEN
|
|
|
+ strPool [strTop] := CHR (first) ;
|
|
|
+ INC (strTop) ;
|
|
|
+ strLen [x] := 1
|
|
|
+ END ;
|
|
|
+ rdStrX := x ;
|
|
|
+ RETURN x
|
|
|
+END StrNew ;
|
|
|
+
|
|
|
+PROCEDURE StrPut (x : CARDINAL ) ;
|
|
|
+(* append the current source character to pool slot x *)
|
|
|
+BEGIN
|
|
|
+ IF x > HIGH (strOff) THEN
|
|
|
+ RETURN
|
|
|
+ END ;
|
|
|
+ IF strTop > HIGH (strPool) THEN
|
|
|
+ Err (ECompOvf) ; (* literal longer than the pool *)
|
|
|
+ RETURN
|
|
|
+ END ;
|
|
|
+ strPool [strTop] := CurCh () ;
|
|
|
+ INC (strTop) ;
|
|
|
+ INC (strLen [x])
|
|
|
+END StrPut ;
|
|
|
+
|
|
|
PROCEDURE RdConst (VAR v : LONGINT ; VAR cls : CARDINAL ;
|
|
|
VAR isStr : BOOLEAN) ;
|
|
|
-(* scalar or string constant. String values (isStr) can only be
|
|
|
- rejected with ENoLib by the caller. *)
|
|
|
+(* scalar or string constant. A string literal's text is collected into the
|
|
|
+ pool and its slot index left in rdStrX; a single-character literal stays a
|
|
|
+ TScalar holding its character code, which is what "c := 'a'" wants. *)
|
|
|
CONST q = AposC ;
|
|
|
BEGIN
|
|
|
isStr := FALSE ;
|
|
|
@@ -1132,9 +1204,15 @@ BEGIN
|
|
|
ELSIF ORD (CurCh ()) = q THEN
|
|
|
DropCh (GetCh ()) ;
|
|
|
IF ORD (CurCh ()) = q THEN
|
|
|
+ (* '' - the empty string. It used to be reported as the scalar 39,
|
|
|
+ so writeln('') printed a single quote mark. It is a string of
|
|
|
+ length zero, and an inline zero-length literal is exactly what the
|
|
|
+ runtime's JCXZ path is for. *)
|
|
|
DropCh (GetCh ()) ;
|
|
|
- v := VAL (LONGINT, q) ;
|
|
|
- cls := TScalar
|
|
|
+ isStr := TRUE ;
|
|
|
+ cls := TString ;
|
|
|
+ v := 0 ;
|
|
|
+ rdStrX := StrNew (0, FALSE)
|
|
|
ELSIF (CurCh () = 0C) OR ((ORD (CurCh ()) = 0DH)) OR ((ORD (CurCh ()) = 0AH)) THEN
|
|
|
Err (EUnknown)
|
|
|
ELSE
|
|
|
@@ -1154,11 +1232,16 @@ BEGIN
|
|
|
satisfied, and the scan runs on to end-of-buffer - which
|
|
|
silently eats the rest of the program and makes every later
|
|
|
error point at end-of-file. Stop on the quote itself, and
|
|
|
- treat a doubled quote as one embedded quote character. *)
|
|
|
+ treat a doubled quote as one embedded quote character.
|
|
|
+
|
|
|
+ The first character is already gone - it was read into v above -
|
|
|
+ so the pool slot is pre-seeded with it. *)
|
|
|
+ rdStrX := StrNew (VAL (CARDINAL, v), TRUE) ;
|
|
|
LOOP
|
|
|
IF ORD (CurCh ()) = q THEN
|
|
|
IF ORD (PeekAhead (1)) = q THEN
|
|
|
- DropCh (GetCh ()) ; DropCh (GetCh ()) (* '' inside *)
|
|
|
+ StrPut (rdStrX) ; (* '' inside *)
|
|
|
+ DropCh (GetCh ()) ; DropCh (GetCh ())
|
|
|
ELSE
|
|
|
EXIT (* closing quote *)
|
|
|
END
|
|
|
@@ -1166,6 +1249,7 @@ BEGIN
|
|
|
Err (EUnknown) ; (* unterminated *)
|
|
|
EXIT
|
|
|
ELSE
|
|
|
+ StrPut (rdStrX) ;
|
|
|
DropCh (GetCh ())
|
|
|
END
|
|
|
END ;
|
|
|
@@ -1199,8 +1283,20 @@ PROCEDURE EmCallMost (idx, nk : CARDINAL) ; FORWARD ;
|
|
|
(* ---------------------------------------------------------------- *)
|
|
|
|
|
|
PROCEDURE LoadAtom (VAR r : ERes) ;
|
|
|
-(* load value of r into AX (folding constants) *)
|
|
|
+(* load value of r into AX (folding constants).
|
|
|
+
|
|
|
+ A string literal is refused here, and this is the single place that has to:
|
|
|
+ assignment, IF, WHILE, FOR, REPEAT, CASE, array subscripts and every
|
|
|
+ operator all reach their operand through LoadAtom, and none of them can use
|
|
|
+ a counted string where a 16-bit word is expected. Reporting it here rather
|
|
|
+ than in the parser means writeln('hi') still works - IoCall handles a
|
|
|
+ literal before it ever calls LoadAtom. *)
|
|
|
BEGIN
|
|
|
+ IF r.cls = TString THEN
|
|
|
+ Err (ENoLib) ; (* string value used as a number *)
|
|
|
+ r.kind := 2 ;
|
|
|
+ RETURN
|
|
|
+ END ;
|
|
|
IF r.kind = 0 THEN
|
|
|
EmMovAxi (W16 (r.imm)) ;
|
|
|
r.kind := 2
|
|
|
@@ -1559,8 +1655,13 @@ BEGIN
|
|
|
RETURN
|
|
|
END ;
|
|
|
IF strf THEN
|
|
|
- Err (ENoLib) ;
|
|
|
- r.kind := 2 ;
|
|
|
+ (* 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 ;
|
|
|
@@ -1790,6 +1891,8 @@ PROCEDURE IoCall (idx : CARDINAL) ;
|
|
|
VAR args : ARRAY [0..15] OF ERes ;
|
|
|
nArgs, i, ent, which, acls : CARDINAL ;
|
|
|
reading : BOOLEAN ;
|
|
|
+ pushed : BOOLEAN ;
|
|
|
+ n : CARDINAL ;
|
|
|
dummy : ERes ;
|
|
|
BEGIN
|
|
|
which := symtab [idx].cls ; (* BI_* *)
|
|
|
@@ -1833,6 +1936,7 @@ BEGIN
|
|
|
to 65535 in CARDINAL and spin 65536 times. *)
|
|
|
IF nArgs > 0 THEN
|
|
|
FOR i := 0 TO nArgs - 1 DO
|
|
|
+ pushed := TRUE ; (* default: value is on the stack -> call + pop *)
|
|
|
IF reading THEN
|
|
|
IF args [i].kind # 1 THEN
|
|
|
Err (ETypeErr) ; (* READ needs a variable *)
|
|
|
@@ -1855,26 +1959,60 @@ BEGIN
|
|
|
END
|
|
|
ELSE
|
|
|
acls := args [i].cls ;
|
|
|
- IF acls = TString THEN
|
|
|
- Err (ENoLib) ; (* string runtime pending *)
|
|
|
- RETURN
|
|
|
- END ;
|
|
|
- LoadAtom (args [i]) ;
|
|
|
- EmPushAx () ;
|
|
|
- IF args [i].chr THEN
|
|
|
- ent := TU_WrChar (* 'a' - one char, not 97 *)
|
|
|
- ELSIF acls = TReal THEN
|
|
|
- ent := TU_WrReal
|
|
|
- ELSIF acls = TBool THEN
|
|
|
- ent := TU_WrBool
|
|
|
- ELSIF acls = TScalar THEN
|
|
|
- ent := TU_WrInt
|
|
|
+ IF (acls = TString) AND (args [i].kind = 3) THEN
|
|
|
+ (* An inline string literal. TP3 TPSRC8 pwrinlin special-cases a
|
|
|
+ literal that is followed directly by ',' or ')' - i.e. an
|
|
|
+ argument, not an expression - and emits
|
|
|
+ CALL wrtinl <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.
|
|
|
+ Mirrored exactly, so the literal costs only its own characters
|
|
|
+ in the code stream and nothing in the data segment. *)
|
|
|
+ IF strLen [args [i].strx] > 255 THEN
|
|
|
+ (* The length is one byte, so a literal of 256 characters or
|
|
|
+ more would wrap: 300 characters emitted behind a length of
|
|
|
+ 44, and the runtime would print 44 of them and silently drop
|
|
|
+ the rest. TP3 strings are at most 255 characters, so refuse
|
|
|
+ rather than truncate. *)
|
|
|
+ Err (EConstRange) ;
|
|
|
+ RETURN
|
|
|
+ END ;
|
|
|
+ DropC (EmCall (TU_WrInl)) ;
|
|
|
+ Ebyte (VAL (BYTE, strLen [args [i].strx])) ;
|
|
|
+ n := 0 ;
|
|
|
+ WHILE n < strLen [args [i].strx] DO
|
|
|
+ Ebyte (VAL (BYTE, ORD (strPool [strOff [args [i].strx] + n]))) ;
|
|
|
+ INC (n)
|
|
|
+ END ;
|
|
|
+ pushed := FALSE (* nothing was pushed for this one *)
|
|
|
ELSE
|
|
|
- ent := TU_WrChar
|
|
|
+ IF acls = TString THEN
|
|
|
+ (* A string *variable*. Not emitted rather than emitted wrongly:
|
|
|
+ EmPushVarAddr's local form is still wrong (see the note on
|
|
|
+ that procedure), and a wrong address here would print
|
|
|
+ garbage instead of failing. *)
|
|
|
+ Err (ENoLib) ;
|
|
|
+ RETURN
|
|
|
+ END ;
|
|
|
+ LoadAtom (args [i]) ;
|
|
|
+ EmPushAx () ;
|
|
|
+ IF args [i].chr THEN
|
|
|
+ ent := TU_WrChar (* 'a' - one char, not 97 *)
|
|
|
+ ELSIF acls = TReal THEN
|
|
|
+ ent := TU_WrReal
|
|
|
+ ELSIF acls = TBool THEN
|
|
|
+ ent := TU_WrBool
|
|
|
+ ELSIF acls = TScalar THEN
|
|
|
+ ent := TU_WrInt
|
|
|
+ ELSE
|
|
|
+ ent := TU_WrChar
|
|
|
+ END
|
|
|
END
|
|
|
END ;
|
|
|
- DropC (EmCall (ent)) ;
|
|
|
- EmAddSp (2) (* one 16-bit argument *)
|
|
|
+ IF pushed THEN
|
|
|
+ DropC (EmCall (ent)) ;
|
|
|
+ EmAddSp (2) (* one 16-bit argument *)
|
|
|
+ END
|
|
|
END
|
|
|
END ;
|
|
|
IF which = BI_WriteLn THEN
|
|
|
@@ -2705,6 +2843,9 @@ BEGIN
|
|
|
srcLen := Length () ;
|
|
|
pc := 0 ;
|
|
|
dc := 100H ;
|
|
|
+ strTop := 0 ;
|
|
|
+ strCnt := 0 ;
|
|
|
+ rdStrX := 0 ;
|
|
|
varspc := 0 ;
|
|
|
symTop := 0 ;
|
|
|
nPatch := 0 ;
|