|
@@ -168,7 +168,7 @@ CONST
|
|
|
compiled to a + b. Only the constant-folding path was right, which is
|
|
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
|
|
why n * n with n a CONST was correct and a * b with a a variable was
|
|
|
not. *)
|
|
not. *)
|
|
|
- OpAdd = 1 ; OpSub = 2 ; OpMul = 3 ;
|
|
|
|
|
|
|
+ OpAdd = 1 ; OpSub = 2 ; OpMul = 3 ; OpDiv = 4 ;
|
|
|
|
|
|
|
|
(* TP3 error numbers *)
|
|
(* TP3 error numbers *)
|
|
|
ENoSemi = 1 ; EPointExp = 10 ; ESimpType = 30 ;
|
|
ENoSemi = 1 ; EPointExp = 10 ; ESimpType = 30 ;
|
|
@@ -388,6 +388,9 @@ VAR
|
|
|
TU_WrInt : CARDINAL ; TU_WrIntW : CARDINAL ;
|
|
TU_WrInt : CARDINAL ; TU_WrIntW : CARDINAL ;
|
|
|
TU_WrChar : CARDINAL ; TU_WrBool : CARDINAL ;
|
|
TU_WrChar : CARDINAL ; TU_WrBool : CARDINAL ;
|
|
|
TU_WrReal : CARDINAL ; TU_RealWrite : CARDINAL ; TU_RealFmt : 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_WrLn : CARDINAL ;
|
|
TU_WrLn : CARDINAL ;
|
|
|
TU_RdInt : CARDINAL ; TU_RdChar : CARDINAL ; TU_RdBool : CARDINAL ;
|
|
TU_RdInt : CARDINAL ; TU_RdChar : CARDINAL ; TU_RdBool : CARDINAL ;
|
|
|
TU_RdLn : CARDINAL ; TU_Halt : CARDINAL ;
|
|
TU_RdLn : CARDINAL ; TU_Halt : CARDINAL ;
|
|
@@ -1323,6 +1326,10 @@ BEGIN
|
|
|
END
|
|
END
|
|
|
END EmLoadVar ;
|
|
END EmLoadVar ;
|
|
|
|
|
|
|
|
|
|
+PROCEDURE EmXorByteGlob (off, v : CARDINAL) ;
|
|
|
|
|
+BEGIN Ebyte (80H) ; Ebyte (36H) ; Eword ((off + LoadBias) MOD 10000H) ;
|
|
|
|
|
+ Ebyte (VAL (BYTE, v)) END EmXorByteGlob ;
|
|
|
|
|
+
|
|
|
PROCEDURE EmStoreVar (local : BOOLEAN ; off, nbytes : CARDINAL) ;
|
|
PROCEDURE EmStoreVar (local : BOOLEAN ; off, nbytes : CARDINAL) ;
|
|
|
BEGIN
|
|
BEGIN
|
|
|
IF nbytes = 1 THEN
|
|
IF nbytes = 1 THEN
|
|
@@ -2371,6 +2378,11 @@ PROCEDURE ParseCallArgs (idx : CARDINAL) ; FORWARD ;
|
|
|
PROCEDURE EmCallMost (idx, cleanup : CARDINAL) ; FORWARD ;
|
|
PROCEDURE EmCallMost (idx, cleanup : CARDINAL) ; FORWARD ;
|
|
|
PROCEDURE SlotSize (cls, size : CARDINAL) : CARDINAL ; FORWARD ;
|
|
PROCEDURE SlotSize (cls, size : CARDINAL) : CARDINAL ; FORWARD ;
|
|
|
PROCEDURE ParamSlotBytes (e : SymEntry) : 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 IntToMbf (v : LONGINT ; VAR b : ARRAY OF CHAR) ; FORWARD ;
|
|
|
|
|
|
|
|
(* ---------------------------------------------------------------- *)
|
|
(* ---------------------------------------------------------------- *)
|
|
|
(* expressions (TPSRC9) *)
|
|
(* expressions (TPSRC9) *)
|
|
@@ -2829,6 +2841,10 @@ PROCEDURE BinOpEmit (op : CARDINAL ; left, right : ERes ; VAR res : ERes) ;
|
|
|
VAR f : LONGINT ;
|
|
VAR f : LONGINT ;
|
|
|
okc : BOOLEAN ;
|
|
okc : BOOLEAN ;
|
|
|
BEGIN
|
|
BEGIN
|
|
|
|
|
+ IF (left.cls = TReal) OR (right.cls = TReal) THEN
|
|
|
|
|
+ RealBin (op, left, right, res) ;
|
|
|
|
|
+ RETURN
|
|
|
|
|
+ END ;
|
|
|
IF StrOperand (left) OR StrOperand (right) THEN
|
|
IF StrOperand (left) OR StrOperand (right) THEN
|
|
|
(* A string OPERAND - a STRING or a CHAR, which is a one-character string
|
|
(* 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
|
|
for this purpose - makes this a string operation, and `+' is the only
|
|
@@ -2939,6 +2955,7 @@ END ConstCmp ;
|
|
|
(* ---------------------------------------------------------------- *)
|
|
(* ---------------------------------------------------------------- *)
|
|
|
|
|
|
|
|
PROCEDURE SaveLeft (VAR left : ERes) ;
|
|
PROCEDURE SaveLeft (VAR left : ERes) ;
|
|
|
|
|
+VAR sk : CARDINAL ;
|
|
|
(* Called the moment the operator has been recognised, i.e. *before* the
|
|
(* Called the moment the operator has been recognised, i.e. *before* the
|
|
|
right-hand operand is parsed.
|
|
right-hand operand is parsed.
|
|
|
|
|
|
|
@@ -2961,7 +2978,17 @@ PROCEDURE SaveLeft (VAR left : ERes) ;
|
|
|
ORed the *second* comparison's result with itself - which is why it
|
|
ORed the *second* comparison's result with itself - which is why it
|
|
|
printed FALSE for TRUE or FALSE. *)
|
|
printed FALSE for TRUE or FALSE. *)
|
|
|
BEGIN
|
|
BEGIN
|
|
|
- IF left.kind = 2 THEN
|
|
|
|
|
|
|
+ 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 () ;
|
|
EmPushAx () ;
|
|
|
left.kind := 4 (* 4 = on the top of the stack *)
|
|
left.kind := 4 (* 4 = on the top of the stack *)
|
|
|
ELSIF left.kind = 5 THEN
|
|
ELSIF left.kind = 5 THEN
|
|
@@ -3050,6 +3077,28 @@ BEGIN
|
|
|
RETURN here
|
|
RETURN here
|
|
|
END EmStrBlob ;
|
|
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) ;
|
|
PROCEDURE EmPushSetAddr (r : ERes) ;
|
|
|
(* Push the ADDRESS of a set value: the runtime's set entries take addresses.
|
|
(* 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
|
|
A set literal/typed constant is code-resident (kind 7), a set-expression
|
|
@@ -3238,6 +3287,34 @@ BEGIN
|
|
|
Ebyte (0E2H) ; Ebyte (0F8H) (* LOOP back *)
|
|
Ebyte (0E2H) ; Ebyte (0F8H) (* LOOP back *)
|
|
|
END EmPushRealSlot ;
|
|
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) ;
|
|
PROCEDURE EmPushStrSlot (r : ERes ; reserve, copyN : CARDINAL) ;
|
|
|
(* Push a STRING VALUE argument's whole slot: reserve `reserve' bytes on the
|
|
(* 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
|
|
stack and copy `copyN' of the source string's <len><chars> into them, so
|
|
@@ -3584,6 +3661,14 @@ BEGIN
|
|
|
RETURN symTop - 1
|
|
RETURN symTop - 1
|
|
|
END NewScratchReal ;
|
|
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 ;
|
|
PROCEDURE StrOperand (r : ERes) : BOOLEAN ;
|
|
|
(* Is r usable as one operand of `+'? A STRING, or a CHAR - which can appear
|
|
(* 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
|
|
three ways: a quoted literal (cls TScalar with chr set), a CHAR variable
|
|
@@ -3703,7 +3788,7 @@ PROCEDURE ParseCmp (VAR r : ERes) ;
|
|
|
VAR op : CARDINAL ;
|
|
VAR op : CARDINAL ;
|
|
|
left, right : ERes ;
|
|
left, right : ERes ;
|
|
|
f : LONGINT ;
|
|
f : LONGINT ;
|
|
|
- size, base : CARDINAL ;
|
|
|
|
|
|
|
+ size, base, block : CARDINAL ;
|
|
|
BEGIN
|
|
BEGIN
|
|
|
ParseAdd (r) ;
|
|
ParseAdd (r) ;
|
|
|
LOOP
|
|
LOOP
|
|
@@ -3807,6 +3892,34 @@ BEGIN
|
|
|
EmRelSetcc (op) ;
|
|
EmRelSetcc (op) ;
|
|
|
r.kind := 2 ;
|
|
r.kind := 2 ;
|
|
|
r.cls := TBool
|
|
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 # 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
|
|
ELSE
|
|
|
SaveLeft (left) ;
|
|
SaveLeft (left) ;
|
|
|
ParseAdd (right) ;
|
|
ParseAdd (right) ;
|
|
@@ -3903,7 +4016,7 @@ BEGIN
|
|
|
IF CurCh () = '*' THEN
|
|
IF CurCh () = '*' THEN
|
|
|
op := OpMul ; DropCh (GetCh ()) (* OpAdd here meant a*b -> a+b *)
|
|
op := OpMul ; DropCh (GetCh ()) (* OpAdd here meant a*b -> a+b *)
|
|
|
ELSIF CurCh () = '/' THEN
|
|
ELSIF CurCh () = '/' THEN
|
|
|
- op := 2 ; DropCh (GetCh ()) ; Err (ENoLib)
|
|
|
|
|
|
|
+ op := OpDiv ; DropCh (GetCh ())
|
|
|
ELSIF KwAhead ("DIV") THEN
|
|
ELSIF KwAhead ("DIV") THEN
|
|
|
GetWord () ; op := TkDiv
|
|
GetWord () ; op := TkDiv
|
|
|
ELSIF KwAhead ("MOD") THEN
|
|
ELSIF KwAhead ("MOD") THEN
|
|
@@ -3913,9 +4026,6 @@ BEGIN
|
|
|
ELSE
|
|
ELSE
|
|
|
RETURN
|
|
RETURN
|
|
|
END ;
|
|
END ;
|
|
|
- IF op = 2 THEN
|
|
|
|
|
- RETURN
|
|
|
|
|
- END ;
|
|
|
|
|
left := r ;
|
|
left := r ;
|
|
|
IF left.cls = TSet THEN
|
|
IF left.cls = TSet THEN
|
|
|
(* Set intersection. Same push-before-the-right rule as ParseAdd. *)
|
|
(* Set intersection. Same push-before-the-right rule as ParseAdd. *)
|
|
@@ -3959,7 +4069,15 @@ BEGIN
|
|
|
ELSIF CurCh () = '-' THEN
|
|
ELSIF CurCh () = '-' THEN
|
|
|
DropCh (GetCh ()) ;
|
|
DropCh (GetCh ()) ;
|
|
|
ParseNeg (r) ;
|
|
ParseNeg (r) ;
|
|
|
- IF r.kind = 0 THEN
|
|
|
|
|
|
|
+ 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))
|
|
r.imm := VAL (LONGINT, W16 (0 - r.imm))
|
|
|
ELSE
|
|
ELSE
|
|
|
LoadAtom (r) ;
|
|
LoadAtom (r) ;
|
|
@@ -4058,6 +4176,7 @@ VAR idx : CARDINAL ;
|
|
|
ssize, sbase : CARDINAL ;
|
|
ssize, sbase : CARDINAL ;
|
|
|
sbuf : ARRAY [0..31] OF CHAR ;
|
|
sbuf : ARRAY [0..31] OF CHAR ;
|
|
|
uj1, uj2 : CARDINAL ;
|
|
uj1, uj2 : CARDINAL ;
|
|
|
|
|
+ litStart, scratch, asciiAddr : CARDINAL ;
|
|
|
BEGIN
|
|
BEGIN
|
|
|
r.chr := FALSE ; (* default: not a quoted char literal *)
|
|
r.chr := FALSE ; (* default: not a quoted char literal *)
|
|
|
Skip () ;
|
|
Skip () ;
|
|
@@ -4092,11 +4211,25 @@ BEGIN
|
|
|
caret (^M) or decimal (#27) character constant is a character too. *)
|
|
caret (^M) or decimal (#27) character constant is a character too. *)
|
|
|
quoted := (ORD (CurCh ()) = AposC) OR (CurCh () = '^')
|
|
quoted := (ORD (CurCh ()) = AposC) OR (CurCh () = '^')
|
|
|
OR (CurCh () = '#') ;
|
|
OR (CurCh () = '#') ;
|
|
|
|
|
+ litStart := srcPos ;
|
|
|
RdConst (r.imm, r.cls, strf) ;
|
|
RdConst (r.imm, r.cls, strf) ;
|
|
|
r.chr := quoted AND (r.cls = TScalar) AND NOT strf ;
|
|
r.chr := quoted AND (r.cls = TScalar) AND NOT strf ;
|
|
|
IF r.cls = TReal THEN
|
|
IF r.cls = TReal THEN
|
|
|
- Err (ENoLib) ;
|
|
|
|
|
- r.kind := 2 ;
|
|
|
|
|
|
|
+ (* 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
|
|
RETURN
|
|
|
END ;
|
|
END ;
|
|
|
IF strf THEN
|
|
IF strf THEN
|
|
@@ -4125,6 +4258,15 @@ BEGIN
|
|
|
Err (EUnknown) ;
|
|
Err (EUnknown) ;
|
|
|
RETURN
|
|
RETURN
|
|
|
END ;
|
|
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
|
|
IF symtab [idx].tag = KConst THEN
|
|
|
r.kind := 0 ;
|
|
r.kind := 0 ;
|
|
|
r.imm := symtab [idx].lval ;
|
|
r.imm := symtab [idx].lval ;
|
|
@@ -4689,6 +4831,39 @@ BEGIN
|
|
|
END
|
|
END
|
|
|
END IntToMbf ;
|
|
END IntToMbf ;
|
|
|
|
|
|
|
|
|
|
+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
|
|
|
|
|
+ EmCopyRealTo (symtab [block].off + 6, right) ;
|
|
|
|
|
+ EmCopyRealTo (symtab [block].off, left)
|
|
|
|
|
+ ELSE
|
|
|
|
|
+ EmCopyRealTo (symtab [block].off, left) ;
|
|
|
|
|
+ EmCopyRealTo (symtab [block].off + 6, right)
|
|
|
|
|
+ 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 Assignment (r : ERes) ;
|
|
PROCEDURE Assignment (r : ERes) ;
|
|
|
(* ':=' already consumed by the caller; store expression into r *)
|
|
(* ':=' already consumed by the caller; store expression into r *)
|
|
|
VAR src : ERes ;
|
|
VAR src : ERes ;
|
|
@@ -4776,6 +4951,19 @@ BEGIN
|
|
|
END ;
|
|
END ;
|
|
|
RETURN
|
|
RETURN
|
|
|
END ;
|
|
END ;
|
|
|
|
|
+ IF (src.kind = 5) AND (src.cls = TReal) AND (r.kind = 1) THEN
|
|
|
|
|
+ EmPushDi () ;
|
|
|
|
|
+ EmPopSi () ;
|
|
|
|
|
+ k := 0 ;
|
|
|
|
|
+ WHILE k < 6 DO
|
|
|
|
|
+ EmLdAlSi () ;
|
|
|
|
|
+ EmStoreVar (symtab [r.idx].local,
|
|
|
|
|
+ (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 (src.kind = 1) AND (src.cls = TReal) THEN
|
|
|
IF r.kind = 5 THEN
|
|
IF r.kind = 5 THEN
|
|
|
IF src.kind = 5 THEN
|
|
IF src.kind = 5 THEN
|
|
@@ -6485,12 +6673,26 @@ BEGIN
|
|
|
ExpectDelim ('[', ENoSemi) ;
|
|
ExpectDelim ('[', ENoSemi) ;
|
|
|
an := 0 ;
|
|
an := 0 ;
|
|
|
LOOP
|
|
LOOP
|
|
|
- RdConst (lo, subcls, strf) ;
|
|
|
|
|
- IF NOT MatchRange () THEN
|
|
|
|
|
- Err (ESimpType) ;
|
|
|
|
|
- RETURN
|
|
|
|
|
|
|
+ Skip () ;
|
|
|
|
|
+ IF Alpha (CurCh ()) THEN
|
|
|
|
|
+ (* An enum/subrange TYPE as the index: `array[Standardfunction]'.
|
|
|
|
|
+ Its bounds are on the type symbol. *)
|
|
|
|
|
+ GetWord () ;
|
|
|
|
|
+ IF NOT Search (wrd, idx) OR (symtab [idx].tag # KType)
|
|
|
|
|
+ OR (symtab [idx].cls # TEnum) THEN
|
|
|
|
|
+ Err (ESimpType) ;
|
|
|
|
|
+ RETURN
|
|
|
|
|
+ END ;
|
|
|
|
|
+ lo := symtab [idx].lo ;
|
|
|
|
|
+ hi := symtab [idx].hi
|
|
|
|
|
+ ELSE
|
|
|
|
|
+ RdConst (lo, subcls, strf) ;
|
|
|
|
|
+ IF NOT MatchRange () THEN
|
|
|
|
|
+ Err (ESimpType) ;
|
|
|
|
|
+ RETURN
|
|
|
|
|
+ END ;
|
|
|
|
|
+ RdConst (hi, subcls, strf)
|
|
|
END ;
|
|
END ;
|
|
|
- RdConst (hi, subcls, strf) ;
|
|
|
|
|
IF an < 4 THEN
|
|
IF an < 4 THEN
|
|
|
alo [an] := lo ;
|
|
alo [an] := lo ;
|
|
|
ahi [an] := hi ;
|
|
ahi [an] := hi ;
|
|
@@ -6757,7 +6959,7 @@ BEGIN
|
|
|
IF lexnest = 0 THEN
|
|
IF lexnest = 0 THEN
|
|
|
IF (size > 2) AND (cls # TString) AND (cls # TRecord)
|
|
IF (size > 2) AND (cls # TString) AND (cls # TRecord)
|
|
|
AND (cls # TArray) AND (cls # TFile) AND (cls # TText)
|
|
AND (cls # TArray) AND (cls # TFile) AND (cls # TText)
|
|
|
- AND (cls # TUntyp) THEN
|
|
|
|
|
|
|
+ AND (cls # TUntyp) AND (cls # TReal) THEN
|
|
|
(* Still the catch-all for a type whose storage this compiler does
|
|
(* Still the catch-all for a type whose storage this compiler does
|
|
|
not lay out yet (an ARRAY at its point of use, a RECORD, ...).
|
|
not lay out yet (an ARRAY at its point of use, a RECORD, ...).
|
|
|
A STRING is the exception now: its layout is length byte +
|
|
A STRING is the exception now: its layout is length byte +
|
|
@@ -6803,7 +7005,7 @@ BEGIN
|
|
|
ELSE
|
|
ELSE
|
|
|
IF (size > 2) AND (cls # TString) AND (cls # TRecord)
|
|
IF (size > 2) AND (cls # TString) AND (cls # TRecord)
|
|
|
AND (cls # TArray) AND (cls # TFile) AND (cls # TText)
|
|
AND (cls # TArray) AND (cls # TFile) AND (cls # TText)
|
|
|
- AND (cls # TUntyp) THEN
|
|
|
|
|
|
|
+ AND (cls # TUntyp) AND (cls # TReal) THEN
|
|
|
Err (ENoLib) ;
|
|
Err (ENoLib) ;
|
|
|
RETURN
|
|
RETURN
|
|
|
END ;
|
|
END ;
|
|
@@ -6859,7 +7061,7 @@ VAR nm : ARRAY [0..MaxName] OF CHAR ;
|
|
|
isStr : BOOLEAN ;
|
|
isStr : BOOLEAN ;
|
|
|
tok : CARDINAL ;
|
|
tok : CARDINAL ;
|
|
|
typed, setTyped, arrTyped : BOOLEAN ;
|
|
typed, setTyped, arrTyped : BOOLEAN ;
|
|
|
- nb, k, divi, w : CARDINAL ;
|
|
|
|
|
|
|
+ nb, k, divi, w, slen : CARDINAL ;
|
|
|
BEGIN
|
|
BEGIN
|
|
|
LOOP
|
|
LOOP
|
|
|
PeekKw (tok) ;
|
|
PeekKw (tok) ;
|
|
@@ -6921,18 +7123,39 @@ BEGIN
|
|
|
nb := 0 ;
|
|
nb := 0 ;
|
|
|
LOOP
|
|
LOOP
|
|
|
RdConst (v, cls, isStr) ;
|
|
RdConst (v, cls, isStr) ;
|
|
|
- IF isStr OR (nb + typElem > 512) THEN
|
|
|
|
|
- Err (ENoLib) ;
|
|
|
|
|
|
|
+ IF nb + typElem > 512 THEN
|
|
|
|
|
+ Err (ECompOvf) ;
|
|
|
EXIT
|
|
EXIT
|
|
|
END ;
|
|
END ;
|
|
|
- w := VAL (CARDINAL, W16 (v)) ;
|
|
|
|
|
- divi := 1 ;
|
|
|
|
|
- k := 0 ;
|
|
|
|
|
- WHILE k < typElem DO
|
|
|
|
|
- constBlob [nb] := CHR ((w DIV divi) MOD 256) ;
|
|
|
|
|
- divi := divi * 256 ;
|
|
|
|
|
- INC (nb) ;
|
|
|
|
|
- INC (k)
|
|
|
|
|
|
|
+ IF isStr THEN
|
|
|
|
|
+ (* A string element is <length><chars>, padded with NULs to
|
|
|
|
|
+ typElem bytes. StandardfunctionNames is array of string[6]. *)
|
|
|
|
|
+ slen := strLen [rdStrX] ;
|
|
|
|
|
+ IF slen > typElem - 1 THEN
|
|
|
|
|
+ slen := typElem - 1
|
|
|
|
|
+ END ;
|
|
|
|
|
+ constBlob [nb] := CHR (slen) ;
|
|
|
|
|
+ k := 0 ;
|
|
|
|
|
+ WHILE k < typElem - 1 DO
|
|
|
|
|
+ IF k < slen THEN
|
|
|
|
|
+ constBlob [nb + 1 + k] :=
|
|
|
|
|
+ strPool [strOff [rdStrX] + k]
|
|
|
|
|
+ ELSE
|
|
|
|
|
+ constBlob [nb + 1 + k] := CHR (0)
|
|
|
|
|
+ END ;
|
|
|
|
|
+ INC (k)
|
|
|
|
|
+ END ;
|
|
|
|
|
+ nb := nb + typElem
|
|
|
|
|
+ ELSE
|
|
|
|
|
+ w := VAL (CARDINAL, W16 (v)) ;
|
|
|
|
|
+ divi := 1 ;
|
|
|
|
|
+ k := 0 ;
|
|
|
|
|
+ WHILE k < typElem DO
|
|
|
|
|
+ constBlob [nb] := CHR ((w DIV divi) MOD 256) ;
|
|
|
|
|
+ divi := divi * 256 ;
|
|
|
|
|
+ INC (nb) ;
|
|
|
|
|
+ INC (k)
|
|
|
|
|
+ END
|
|
|
END ;
|
|
END ;
|
|
|
IF MatchDelim (',') THEN
|
|
IF MatchDelim (',') THEN
|
|
|
(* another element *)
|
|
(* another element *)
|
|
@@ -7239,6 +7462,7 @@ BEGIN
|
|
|
resultVar := NewSym (nm, KVar, cls, size, elem,
|
|
resultVar := NewSym (nm, KVar, cls, size, elem,
|
|
|
(locFree - size + 1) MOD 10000H, 0, TRUE) ;
|
|
(locFree - size + 1) MOD 10000H, 0, TRUE) ;
|
|
|
symtab [old].resvar := resultVar ;
|
|
symtab [old].resvar := resultVar ;
|
|
|
|
|
+ symtab [resultVar].resvar := old ; (* reverse link for self-calls *)
|
|
|
locFree := (locFree - size) MOD 10000H ;
|
|
locFree := (locFree - size) MOD 10000H ;
|
|
|
locBytes := locBytes + size ;
|
|
locBytes := locBytes + size ;
|
|
|
resultIsReal := (cls = TReal) ;
|
|
resultIsReal := (cls = TReal) ;
|
|
@@ -7644,6 +7868,12 @@ BEGIN
|
|
|
TU_WrReal := RT_Entry (6) ;
|
|
TU_WrReal := RT_Entry (6) ;
|
|
|
TU_RealWrite := RT_Entry (30) ; (* fmtreal + padding + output *)
|
|
TU_RealWrite := RT_Entry (30) ; (* fmtreal + padding + output *)
|
|
|
TU_RealFmt := RT_Entry (28) ; (* fmtreal into a string variable *)
|
|
TU_RealFmt := RT_Entry (28) ; (* fmtreal into a string variable *)
|
|
|
|
|
+ TU_RealVal := RT_Entry (29) ; (* ascreal: ASCIIZ -> REAL *)
|
|
|
|
|
+ TU_RealCmp := RT_Entry (26) ; (* recmp: AX = -1/0/+1 *)
|
|
|
|
|
+ TU_RealAdd := RT_Entry (22) ;
|
|
|
|
|
+ TU_RealSub := RT_Entry (23) ;
|
|
|
|
|
+ TU_RealMul := RT_Entry (24) ;
|
|
|
|
|
+ TU_RealDiv := RT_Entry (25) ;
|
|
|
TU_WrLn := RT_Entry (7) ;
|
|
TU_WrLn := RT_Entry (7) ;
|
|
|
TU_RdInt := RT_Entry (8) ;
|
|
TU_RdInt := RT_Entry (8) ;
|
|
|
TU_RdChar := RT_Entry (9) ;
|
|
TU_RdChar := RT_Entry (9) ;
|