|
|
@@ -427,6 +427,9 @@ VAR
|
|
|
lexnest : CARDINAL ;
|
|
|
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 *)
|
|
|
@@ -1416,6 +1419,9 @@ BEGIN Ebyte (47H) END EmIncDi ;
|
|
|
PROCEDURE EmMovDiAx () ;
|
|
|
BEGIN Ebyte (89H) ; Ebyte (0C7H) END EmMovDiAx ; (* 89 C7: DI := AX *)
|
|
|
|
|
|
+PROCEDURE EmMovAxDi () ;
|
|
|
+BEGIN Ebyte (89H) ; Ebyte (0F8H) END EmMovAxDi ; (* 89 F8: AX := DI *)
|
|
|
+
|
|
|
PROCEDURE EmLdAxDi () ;
|
|
|
BEGIN Ebyte (8BH) ; Ebyte (05H) END EmLdAxDi ; (* 8B 05: AX := [DI] *)
|
|
|
|
|
|
@@ -3199,6 +3205,39 @@ BEGIN
|
|
|
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
|
|
|
+ EmLoadVar (TRUE, symtab [r.idx].off, 2) ;
|
|
|
+ EmPushAx ()
|
|
|
+ ELSE
|
|
|
+ EmPushVarAddr (symtab [r.idx].local,
|
|
|
+ (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 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
|
|
|
@@ -3537,6 +3576,14 @@ BEGIN
|
|
|
RETURN symTop - 1
|
|
|
END NewScratchStr ;
|
|
|
|
|
|
+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 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
|
|
|
@@ -4085,8 +4132,17 @@ BEGIN
|
|
|
RETURN
|
|
|
ELSIF symtab [idx].tag = KFunc THEN
|
|
|
ParseCall (idx) ;
|
|
|
- r.kind := 2 ;
|
|
|
- r.cls := symtab [idx].cls ;
|
|
|
+ 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 = KVar) OR (symtab [idx].tag = KType) THEN
|
|
|
(* ParseVar initialises boff to 0 and then ParseSub folds any constant
|
|
|
@@ -4406,24 +4462,27 @@ BEGIN
|
|
|
`copyN' is at most the slot: an actual shorter than the formal
|
|
|
leaves the tail untouched, which is harmless because the length
|
|
|
byte bounds every read. *)
|
|
|
- IF arg.cls # TString THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- EXIT
|
|
|
- END ;
|
|
|
- nCopy := slot ;
|
|
|
- IF arg.kind = 1 THEN
|
|
|
- IF VarSize (arg) < nCopy THEN
|
|
|
- nCopy := VarSize (arg)
|
|
|
- END
|
|
|
- ELSIF arg.kind = 3 THEN
|
|
|
- IF strLen [arg.strx] + 1 < nCopy THEN
|
|
|
- nCopy := strLen [arg.strx] + 1
|
|
|
- END
|
|
|
+ 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 (ENoLib) ; (* a computed string is not a value *)
|
|
|
+ Err (ETypeErr) ;
|
|
|
EXIT
|
|
|
- END ;
|
|
|
- EmPushStrSlot (arg, slot, nCopy)
|
|
|
+ END
|
|
|
ELSE
|
|
|
LoadAtom (arg) ;
|
|
|
EmPushAx ()
|
|
|
@@ -4480,24 +4539,27 @@ BEGIN
|
|
|
END
|
|
|
ELSIF slot > 2 THEN
|
|
|
(* see ParseCallArgs: push the whole string slot *)
|
|
|
- IF arg.cls # TString THEN
|
|
|
- Err (ETypeErr) ;
|
|
|
- EXIT
|
|
|
- END ;
|
|
|
- nCopy := slot ;
|
|
|
- IF arg.kind = 1 THEN
|
|
|
- IF VarSize (arg) < nCopy THEN
|
|
|
- nCopy := VarSize (arg)
|
|
|
- END
|
|
|
- ELSIF arg.kind = 3 THEN
|
|
|
- IF strLen [arg.strx] + 1 < nCopy THEN
|
|
|
- nCopy := strLen [arg.strx] + 1
|
|
|
- END
|
|
|
+ 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 (ENoLib) ;
|
|
|
+ Err (ETypeErr) ;
|
|
|
EXIT
|
|
|
- END ;
|
|
|
- EmPushStrSlot (arg, slot, nCopy)
|
|
|
+ END
|
|
|
ELSE
|
|
|
LoadAtom (arg) ;
|
|
|
EmPushAx ()
|
|
|
@@ -4513,6 +4575,11 @@ BEGIN
|
|
|
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 ;
|
|
|
|
|
|
@@ -6936,11 +7003,24 @@ BEGIN
|
|
|
END IfMatchSemi ;
|
|
|
|
|
|
PROCEDURE SymEpi () ;
|
|
|
-(* function result: AX := result var *)
|
|
|
+(* function result: AX := result var for a scalar, or copy six bytes to the
|
|
|
+ caller's result scratch for a REAL function. *)
|
|
|
+VAR k : CARDINAL ;
|
|
|
BEGIN
|
|
|
IF curIsFunc THEN
|
|
|
IF OK () THEN
|
|
|
- EmLoadVar (TRUE, symtab [resultVar].off, symtab [resultVar].size)
|
|
|
+ IF resultIsReal THEN
|
|
|
+ EmLoadVar (TRUE, resultPtrOff, 2) ;
|
|
|
+ EmMovDiAx () ;
|
|
|
+ k := 0 ;
|
|
|
+ WHILE k < 6 DO
|
|
|
+ EmLoadVar (TRUE, symtab [resultVar].off + k, 1) ;
|
|
|
+ EmStDiAlOff (k) ;
|
|
|
+ INC (k)
|
|
|
+ END
|
|
|
+ ELSE
|
|
|
+ EmLoadVar (TRUE, symtab [resultVar].off, symtab [resultVar].size)
|
|
|
+ END
|
|
|
END
|
|
|
END
|
|
|
END SymEpi ;
|
|
|
@@ -6978,7 +7058,9 @@ VAR nm : ARRAY [0..MaxName] OF CHAR ;
|
|
|
cls, size, elem : CARDINAL ;
|
|
|
isFunc, groupVar : BOOLEAN ;
|
|
|
saveNest, saveLoc, saveRes, saveF : CARDINAL ;
|
|
|
- saveLB, savePO : CARDINAL ;
|
|
|
+ saveLB, savePO, saveRP : CARDINAL ;
|
|
|
+ saveR : BOOLEAN ;
|
|
|
+ realResult : BOOLEAN ;
|
|
|
nestMark : CARDINAL ; (* symTop just inside this procedure *)
|
|
|
i, first : CARDINAL ;
|
|
|
BEGIN
|
|
|
@@ -7008,6 +7090,8 @@ BEGIN
|
|
|
saveF := VAL (CARDINAL, ORD (curIsFunc)) ;
|
|
|
saveLB := locBytes ;
|
|
|
savePO := parmOff ;
|
|
|
+ saveRP := resultPtrOff ;
|
|
|
+ saveR := resultIsReal ;
|
|
|
INC (lexnest) ;
|
|
|
nestMark := symTop ; (* after the proc's own name, before its params *)
|
|
|
locFree := 0FFFFH ;
|
|
|
@@ -7055,8 +7139,7 @@ BEGIN
|
|
|
Err (ENoLib) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
- IF (size > 2) AND (cls # TString)
|
|
|
- AND NOT (groupVar AND (cls = TReal)) THEN
|
|
|
+ IF (size > 2) AND (cls # TString) AND (cls # TReal) THEN
|
|
|
(* A string VALUE parameter is a whole-slot copy (n+1 bytes on
|
|
|
the stack); any other type wider than a word - a record, an
|
|
|
array, a set - is still refused. A VAR REAL is allowed:
|
|
|
@@ -7132,15 +7215,22 @@ BEGIN
|
|
|
symtab [old].parmFirst := nestMark ;
|
|
|
symtab [old].parmCount := symTop - nestMark
|
|
|
END ;
|
|
|
+ realResult := FALSE ;
|
|
|
IF isFunc THEN
|
|
|
IF MatchDelim (':') THEN
|
|
|
ParseType (cls, size, elem)
|
|
|
+ ELSIF symtab [old].fwd AND (symtab [old].cls # TNone) THEN
|
|
|
+ (* The definition of a forward repeats only the name; inherit the
|
|
|
+ result type declared by the forward. *)
|
|
|
+ cls := symtab [old].cls ;
|
|
|
+ size := symtab [old].size ;
|
|
|
+ elem := symtab [old].elem
|
|
|
ELSE
|
|
|
cls := TScalar ;
|
|
|
size := 2 ;
|
|
|
elem := 2
|
|
|
END ;
|
|
|
- IF size > 2 THEN
|
|
|
+ IF (size > 2) AND (cls # TReal) THEN
|
|
|
Err (ENoLib) ;
|
|
|
RETURN
|
|
|
END ;
|
|
|
@@ -7150,7 +7240,17 @@ BEGIN
|
|
|
(locFree - size + 1) MOD 10000H, 0, TRUE) ;
|
|
|
symtab [old].resvar := resultVar ;
|
|
|
locFree := (locFree - size) MOD 10000H ;
|
|
|
- locBytes := locBytes + size
|
|
|
+ locBytes := locBytes + size ;
|
|
|
+ resultIsReal := (cls = TReal) ;
|
|
|
+ IF resultIsReal THEN
|
|
|
+ (* Hidden two-byte local holding the caller's result destination.
|
|
|
+ The caller passes it in DI before the CALL. *)
|
|
|
+ resultPtrOff := (locFree - 1) MOD 10000H ;
|
|
|
+ locFree := (locFree - 2) MOD 10000H ;
|
|
|
+ locBytes := locBytes + 2
|
|
|
+ ELSE
|
|
|
+ resultPtrOff := 0
|
|
|
+ END
|
|
|
END ;
|
|
|
IfMatchSemi () ;
|
|
|
PeekKw (tok2) ;
|
|
|
@@ -7164,6 +7264,8 @@ BEGIN
|
|
|
lexnest := saveNest ;
|
|
|
locFree := saveLoc ;
|
|
|
resultVar := saveRes ;
|
|
|
+ resultIsReal := saveR ;
|
|
|
+ resultPtrOff := saveRP ;
|
|
|
curIsFunc := (saveF # 0) ;
|
|
|
locBytes := saveLB ;
|
|
|
parmOff := savePO ;
|
|
|
@@ -7174,6 +7276,12 @@ BEGIN
|
|
|
symtab [old].defnd := TRUE ;
|
|
|
EmPushBp () ;
|
|
|
EmMovBpSp () ;
|
|
|
+ IF resultIsReal THEN
|
|
|
+ (* The caller put the six-byte result destination in DI. Save it
|
|
|
+ before declarations/body can reuse DI. *)
|
|
|
+ EmMovAxDi () ;
|
|
|
+ EmStoreVar (TRUE, resultPtrOff, 2)
|
|
|
+ END ;
|
|
|
DefPart () ; (* nested declarations; stops at BEGIN *)
|
|
|
IF locBytes > 0 THEN
|
|
|
EmSubSp (locBytes)
|
|
|
@@ -7198,6 +7306,8 @@ BEGIN
|
|
|
lexnest := saveNest ;
|
|
|
locFree := saveLoc ;
|
|
|
resultVar := saveRes ;
|
|
|
+ resultIsReal := saveR ;
|
|
|
+ resultPtrOff := saveRP ;
|
|
|
curIsFunc := (saveF # 0) ;
|
|
|
locBytes := saveLB ;
|
|
|
parmOff := savePO
|
|
|
@@ -7477,6 +7587,9 @@ BEGIN
|
|
|
lexnest := 0 ;
|
|
|
curIsFunc := FALSE ;
|
|
|
resultVar := 0 ;
|
|
|
+ resultIsReal := FALSE ;
|
|
|
+ resultPtrOff := 0 ;
|
|
|
+ callScratch := 0 ;
|
|
|
locFree := 0FFFFH ;
|
|
|
locBytes := 0 ;
|
|
|
parmOff := 4 ;
|