Переглянути джерело

calc: REAL function results and value REAL parameters (ladder 32482)

A function returning REAL now writes its six-byte result to a caller-owned
scratch: the call site sets DI to the scratch address, the callee saves it in
a hidden frame local, and SymEpi copies the local result there before leaving.
After the call ParseAtom reloads the scratch address and exposes the result as
a kind-5 REAL value, so it can feed VAR REAL assignment, Str and other
address-based real consumers.  Forward declarations inherit their result type
when the definition repeats only the name.

Value REAL formals reserve six stack bytes.  Call sites copy from a plain
variable, VAR REAL parameter, field or REAL function result; both ParseCall
and ParseCallArgs support it.

t98_realfunc covers a REAL result through a VAR REAL parameter; t99_valreal
covers a value REAL formal whose actual is a VAR REAL and a REAL result.  Both
execute under qemu and Exec86.

The CALC ladder moves 32096 -> 32284 -> 32482; the next blocker is a REAL
constant/comparison (`I > 0.0` in Fact).

Verified: compile matrix 100/100, ladder 1/1, 91 .COM linked, 86 executed
under both qemu and Exec86, rt_exec 276/276, nonvacuity 121/121, run_all ALL
PASS.
Eric Streit 4 днів тому
батько
коміт
884edbaeb5

+ 18 - 9
CALC-COMPILE.md

@@ -97,7 +97,7 @@ Current rung (measured today, normalised position):
 
 | position | blocker |
 |---|---|
-| **32096** | `function Expression(...):Real;forward` — REAL function results (`ERR 102`) |
+| **32482** | `I > 0.0` in `Fact` — REAL constants and comparisons (`ERR 102`) |
 
 Rungs behind it (now passed):
 
@@ -143,7 +143,9 @@ Rungs ahead:
 | 27759 | `Str(count,st)` - integer Str - DONE |
 | 28074 | `Val(Buffer^[0],...)` - string-to-integer - DONE |
 | 31758 | `var Value : Real` - by-reference REAL parameter - DONE |
-| 32096 | REAL function result (`Expression:Real`) |
+| 32096 | REAL function result (`Expression:Real`) - DONE |
+| 32284 | value REAL parameter (`Fact(I : Real)`) - DONE |
+| 32482 | REAL constants/comparisons (`I > 0.0`) |
 
 Corrections the measurements force, worth stating plainly because the stage list
 below was written before them:
@@ -467,8 +469,8 @@ membership, string fields in WRITE, real output, run-time set algebra,
 file control-block operations, VAR string parameters, `Chr`, typed-file
 block I/O, text-file output, `Str`, pointer types with `New`/dereference,
 text `Eof`/`Readln`, integer `Str`, integer `Val`, and VAR REAL parameters). The
-ladder has moved from the first typed constant at 7,791 to **32,096**, where
-`function Expression(...):Real;forward` asks for REAL function results.
+ladder has moved from the first typed constant at 7,791 to **32,482**, where
+`I > 0.0` asks for REAL constants and comparisons.
 
 The rung commits and their tags, in order (each is one rung with its own
 fixture, red proof, and — where the harness allows — execution under qemu and
@@ -513,7 +515,8 @@ Exec86):
 | `1aed9cd` | `v-TP3-CALC-POINTER` | `ERR 41 27648` (`Eof`) |
 | `e940a1d` | `v-TP3-CALC-TEXTREAD` | `ERR 41 28074` (`Val`) |
 | `9d4ab01` | `v-TP3-CALC-VALINT` | `ERR 102 31758` (VAR REAL) |
-| *(this commit)* | `v-TP3-CALC-VARREAL` | **`ERR 102 32096`** (REAL function result) |
+| `a4e72bf` | `v-TP3-CALC-VARREAL` | `ERR 102 32096` (REAL function result) |
+| *(this commit)* | `v-TP3-CALC-REALFUNC` | **`ERR 102 32482`** (REAL constants) |
 
 - **Code HEAD** is the layout rung (`v-TP3-CALC-LAYOUT`).  Nothing is pushed.
   The terminal-config work (`v-TP3-TERMCFG`) and the editor key map
@@ -559,6 +562,13 @@ Exec86):
   parameter slot holds the caller's address; assignment, `Read`, `Length`,
   `writeln`, concatenation, comparison and `x[i]` all go through that address.
   `Chr(n)` folds or loads an ordinal and yields a CHAR.
+- **REAL function results and value REAL parameters are landed**
+  (`t98_realfunc`, `t99_valreal`).  A REAL function's caller supplies a
+  six-byte scratch address in DI; the callee saves it in a hidden local and
+  copies its result there before returning.  Call sites reload the scratch
+  address after the call and treat the result as a kind-5 REAL address.  Value
+  REAL formals reserve six stack bytes and copy from a variable, VAR
+  parameter, field or function result.
 - **VAR REAL parameters are landed (`t97_varreal`).**  The two-byte slot
   holds the caller's address; assignment copies six bytes through it (or
   stores a converted constant), and call sites pass record-field addresses
@@ -1177,10 +1187,9 @@ and TEXT file output is done (`t91_textout`), both compile-only because the
 harness has no filesystem.  `Str` real formatting is done (`t92_strreal`),
 pointer types with `New`/`Dispose`/dereference are done (`t93_pointer`), and
 text `Eof`/`Readln` plus integer `Str` are done (`t94_textread`/`t95_strint`).
-The next ladder blocker is a REAL function result
-(`function Expression(...):Real;forward`).  The probe scaffold has been moved
-to HDR=0x1300 / data 0x2110; the runtime is 4,384 bytes and now has room for
-the remaining work.
+The next ladder blocker is a REAL constant/comparison (`I > 0.0` in `Fact`),
+then the rest of real arithmetic.  The probe scaffold is at HDR=0x1300 / data
+0x2110; the runtime is 4,384 bytes and now has room for the remaining work.
 
 **Stage 14 — the CRT identifiers.** `GotoXY` (25), `LowVideo`/`NormVideo`
 (16 + 16), `ClrEol` (10), `ClrScr` (6), `KeyPressed` (3), `Delay` (1),

+ 3 - 2
SUMMARY.md

@@ -2044,7 +2044,7 @@ the compiler *emitting* a 16,560-byte program). The ratchet and front-end
 features through **file control-block operations and the original memory
 layout** are landed: the ladder (`tests/calc_ladder.sh` +
 `tests/fixtures/calc_ladder.tsv`, run by `run_all.sh`; CALC.PAS now stops at
-`ERR 102` at pos 32096, `function Expression(...):Real;forward`), the `{$I}` include,
+`ERR 102` at pos 32482, `I > 0.0` in Fact), the `{$I}` include,
 `^X`/`#nn`, scalar typed constants, sets, enums, records (CellRec = 80),
 subranges, arrays, element/field access, file types, string value parameters,
 `Length`, the CRT identifiers (`ClrScr`/`GotoXY`/`ClrEol`/`LowVideo`/
@@ -2064,7 +2064,8 @@ parameters plus `Chr` (`t89`), typed-file block I/O (`t90`, compile-only), and
 text-file output (`t91`, compile-only), `Str` real formatting (`t92`), and
 pointer types with `New`/`Dispose`/dereference (`t93`), text `Eof`/`Readln`
 (`t94`), integer `Str` (`t95`), and integer `Val` (`t96`). The next rung is
-REAL function results (`function Expression(...):Real`). The runtime is 3,907 bytes / 39 entries and its probe
+REAL function results (`t98`) and value REAL parameters (`t99`). The next
+rung is REAL constants/comparisons (`I > 0.0`). The runtime is 3,907 bytes / 39 entries and its probe
 scaffold is nearly full, so the next runtime addition must move HDR. Items 1-4
 below are independent of both tracks.
 

+ 154 - 41
shell/Compiler.mod

@@ -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 ;

+ 1 - 0
shell/tests/audit_helpers.py

@@ -161,6 +161,7 @@ NON_ONE_LINE = {
         "FileIo": COMP,        # typed-file INT 21h sequence; see EmFileIo
         "InlineCh": COMP,      # emits a string blob, not one instruction
         "InlineCrLf": COMP,    # emits a string blob, not one instruction
+        "PushRealAddr": COMP, "PushRealSlot": COMP,
         "AddSp": PARAM, "SubSp": PARAM, "Setcc": PARAM,
         "MovChImm": PARAM,
         "Call": COMP, "Jcc": COMP, "JmpNear": COMP,

+ 10 - 10
shell/tests/fixtures/calc_ladder.tsv

@@ -25,13 +25,13 @@
 # positions shift — which is exactly why this must be a measured number, not a
 # remembered one.
 #
-# Current rung (2026-10-23): `function Expression(...):Real;forward;'.  UpCase,
-# run-time set membership, string fields through DI, the original memory
-# layout, untyped-file declarations, file control-block operations, VAR string
-# parameters, Chr, typed-file block I/O, text-file output, Str,
-# pointers/New/dereference, text Eof/Readln, Str(integer), Val(integer) and
-# VAR REAL parameters moved the ladder 15911 -> 18267 -> 19847 -> 20912 ->
-# 22253 -> 22280 -> 22706 -> 22859 -> 23700 -> 25674 -> 26066 -> 26924 ->
-# 27648 -> 28074 -> 31758 -> 32096.  The next blocker is a REAL function
-# result (TP3 error 102).
-CALC.PAS	ERR	102	32096
+# Current rung (2026-10-23): `I > 0.0' in Fact.  UpCase, run-time set
+# membership, string fields through DI, the original memory layout, untyped-file
+# declarations, file control-block operations, VAR string parameters, Chr,
+# typed-file block I/O, text-file output, Str, pointers/New/dereference, text
+# Eof/Readln, Str(integer), Val(integer), VAR REAL parameters, REAL function
+# results and value REAL parameters moved the ladder 15911 -> 18267 -> 19847
+# -> 20912 -> 22253 -> 22280 -> 22706 -> 22859 -> 23700 -> 25674 -> 26066 ->
+# 26924 -> 27648 -> 28074 -> 31758 -> 32096 -> 32284 -> 32482.  The next
+# blocker is REAL constants/comparisons (`I > 0.0', TP3 error 102).
+CALC.PAS	ERR	102	32482

+ 8 - 0
shell/tests/fixtures/expected.tsv

@@ -688,3 +688,11 @@ t96_valint	OK	328	20
 #                   copy through the two-byte address slot, using record fields
 #                   as actual parameters.
 t97_varreal	OK	282	28
+
+#   t98_realfunc         a REAL function result, copied through a VAR REAL
+#                   parameter and formatted with Str.
+t98_realfunc	OK	309	28
+
+#   t99_valreal          value REAL parameters: a six-byte stack slot copied
+#                   from a VAR REAL actual and returned through a REAL function.
+t99_valreal	OK	334	28

+ 1 - 0
shell/tests/fixtures/t98_realfunc.out

@@ -0,0 +1 @@
+3

+ 31 - 0
shell/tests/fixtures/t98_realfunc.pas

@@ -0,0 +1,31 @@
+program t98_realfunc;
+
+{ t98 -- a REAL function result.  `three' returns six bytes through the
+  caller's scratch address; a VAR REAL parameter copies it into a record
+  field, which Str then formats. }
+
+type
+  R = record
+    V : real;
+  end;
+
+var
+  A : R;
+  S : string[10];
+
+function three : real;
+begin
+  three := 3
+end;
+
+procedure put (var Z : real);
+begin
+  Z := three
+end;
+
+begin
+  A.V := 0;
+  put (A.V);
+  Str (A.V : 0 : 0, S);
+  writeln (S)
+end.

+ 1 - 0
shell/tests/fixtures/t99_valreal.out

@@ -0,0 +1 @@
+3

+ 30 - 0
shell/tests/fixtures/t99_valreal.pas

@@ -0,0 +1,30 @@
+program t99_valreal;
+
+{ t99 -- value REAL parameters.  `id(X : real)' receives a six-byte copy on
+  the stack; the argument is a VAR REAL parameter inside `put'. }
+
+type
+  R = record
+    V : real;
+  end;
+
+var
+  A : R;
+  S : string[10];
+
+function id (X : real) : real;
+begin
+  id := X
+end;
+
+procedure put (var Z : real);
+begin
+  Z := id (Z)
+end;
+
+begin
+  A.V := 3;
+  put (A.V);
+  Str (A.V : 0 : 0, S);
+  writeln (S)
+end.