TP3: remaining language conversions, variants and file-adjacent I/O

CALC-COMPILE.md

@@ -97,7 +97,7 @@ Current rung (measured today, normalised position):
 
 | position | blocker |
 |---|---|
-| **compiles** | `CALC.PAS` reaches its final `.` — code **27,484** B, data **19,694** B |
+| **compiles** | `CALC.PAS` reaches its final `.` — code **27,488** B, data **19,694** B |
 
 Rungs behind it (now passed):
 
@@ -164,7 +164,7 @@ Rungs ahead:
 | 51322 | CASE/ELSE closing `end;` - DONE |
 | 52316 | string vs CHAR comparison (`S <> Chr($FF)`) - DONE |
 | 56540 | code-image ceiling - DONE (DataStart moved to 0xA000) |
-| **OK** | **CALC.PAS compiles: code 27,484, data 19,694** |
+| **OK** | **CALC.PAS compiles: code 27,488, data 19,694** |
 
 Corrections the measurements force, worth stating plainly because the stage list
 below was written before them:
@@ -1262,15 +1262,15 @@ include directory, boots it under qemu and feeds the default welcome/quit keys.
 `--keys '\r...'`, `--keys-file`, `--com`, `--raw`, `--timeout` and `--verbose`
 are available; input is a static boot-time key stream, not a live terminal.
 
-**CALC.PAS compiles and runs.**  The runtime is 9,597 bytes; the generated
-program is 27,484 bytes of code and 19,694 bytes of data, with
+**CALC.PAS compiles and runs.**  The runtime is 9,744 bytes; the generated
+program is 27,488 bytes of code and 19,694 bytes of data, with
 `DataStart=0xA000` and `CodeMax=0xA000`.  The boot harness now loads images at
 segment `0x1000` and puts its input descriptor at `0x9800`, so the larger image
 no longer collides with the boot sector/BIOS areas.  The loader reads 77
 sectors and accepts images up to 38,656 bytes.  `tests/calc_smoke.py`
 boots CALC.COM under qemu, enters `1+2` in cell A1, checks the resulting
 `3.00` and the welcome/grid/command menu, sends `/Q`, and requires exit code 0.  The original CALC.COM is 27,901 bytes; ours is
-37,084 bytes because the runtime, static links and code layout differ.
+37,235 bytes because the runtime, static links and code layout differ.
 
 **Stage 14 — the CRT identifiers.** `GotoXY` (25), `LowVideo`/`NormVideo`
 (16 + 16), `ClrEol` (10), `ClrScr` (6), `KeyPressed` (3), `Delay` (1),
@@ -1317,8 +1317,8 @@ remaining run-time capacity note.
 | limit | value | CALC needs | verdict |
 |---|---|---|---|
 | `TextLimit` (source buffer) | 62,903 | `CALC.PAS` + `CALC.INC`, normalised = **62,415** | **488 bytes of slack** |
-| `MaxCode` | 0A000h | 27,484 B program + 9,597 B runtime = **37,081 B** | **OK, 3,879 B spare** |
-| code window | `CodeMax = 0A000h`, capped by `MaxCode` | 27,484 B | **OK**; no data gap (§3.2) |
+| `MaxCode` | 0A000h | 27,488 B program + 9,744 B runtime = **37,232 B** | **OK, 3,728 B spare** |
+| code window | `CodeMax = 0A000h`, capped by `MaxCode` | 27,488 B | **OK**; no data gap (§3.2) |
 | data area | fixed image `0A000h`, zeroed by `initmem` | **19,694 B** (generated) | **OK**; CALC boots under qemu |
 | stack | 16,384 min / 655,360 max | 16,384 min | matches the original's `minstk`/`maxstk` |
 | `MaxSym` | 3,000 | 47 routines + locals + params | **inferred** OK, verify |

CORPUS-TEST.md

@@ -78,18 +78,19 @@ TP3 examples — were deliberately kept.
 Before cleanup: **6,810 files**, **4,919 `.pas`**, **907 zips**.
 After cleanup: **1,731 files**, **71 `.pas`**, **858 zips**.
 
-The remaining 71 Pascal files compile as **58 OK / 13 errors** with the
+The remaining 71 Pascal files compile as **65 OK / 6 errors** with the
 current compiler.  The recent upgrades cover long identifiers, named labels,
 `Addr`, field widths, nested arrays, negative bounds, forward pointer types,
 `NIL`, forward procedure parameters, nested record fields, whole-record/array
 assignment, integer `/` as REAL division, `Ord`, `Succ`/`Pred` on enums, and
-enum subranges, and a leading set constructor in a set expression.  The remaining 13 are TP3-feature gaps, not unit/Delphi noise:
+enum subranges, a leading set constructor in a set expression, Round/Trunc,
+integer-to-REAL assignment, SHL/SHR, address-based pointers, char arrays,
+Msdos/Intr, and variant records.  The remaining 6 are TP3-feature gaps, not
+unit/Delphi noise:
 
-`BINOUT`, `CONVERT`, `DYNREC`, `FINDCHRS`, `LIST3`, `OT3`, `READARRY`,
-`READDATA`, `READINTS`, `READSTOR`, `STRARRAY`, `TIMEDATE`, `VARREC`.
+`FINDCHRS`, `LIST3`, `OT3`, `READDATA`, `READINTS`, `READSTOR`.
 
-They reduce to four groups: `Round`/`Trunc` REAL-to-integer conversion
-(`CONVERT`), pointer-array dereference and variant/`absolute` records
-(`DYNREC`, `LIST3`, `OT3`, `VARREC`), a dynamic set constructor such as
-`[Storage[Index]]` (`FINDCHRS`), and text-file `Read`/`Readln` plus character-array
-and typed-file I/O (`BINOUT`, `READ*`, `STRARRAY`).
+They reduce to three groups: a dynamic set constructor such as
+`[Storage[Index]]` (`FINDCHRS`), DOS `Getdir`/text-file formatting
+(`LIST3`, `OT3`), and text-file numeric `Read`/`Readln`
+(`READDATA`, `READINTS`, `READSTOR`).

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
-**CALC.PAS compiles and runs** (code 27,484, data 19,694), the `{$I}` include,
+**CALC.PAS compiles and runs** (code 27,488, data 19,694), 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`/
@@ -2070,7 +2070,7 @@ standard functions (`Abs`, `Sqr`, `Sqrt`, `Ln`, `Exp`, `Sin`, `Cos`,
 landed, along with `Delete` and local `set of Char` variables.  The math runtime
 was compacted to guest Horner/square loops, reducing it from 14,063 to 9,203
 bytes.  `Insert`, CASE/ELSE trailing semicolons and string-vs-CHAR comparisons
-are also landed.  **CALC.PAS now compiles to its final `.`** with code 27,484
+are also landed.  **CALC.PAS now compiles to its final `.`** with code 27,488
 and data 19,694.  Nested procedures now use a real static link, so a cell can
 be entered and its formula/text edited (the first cell-entry path no longer
 restarts or corrupts the screen).  The boot loader now uses segment 0x1000
@@ -2079,7 +2079,7 @@ in DL as real DOS requires, not only in AL as the private boot handler did;
 CALC is verified under the FreeDOS 1.4 LiveCD (welcome, `1+2` -> `3.00`,
 menu, `/Q`).  `tests/calc_smoke.py` still boots the project harness, enters
 `1+2` in cell A1, checks the resulting `3.00` and quits via `/Q`.  `tests/calc_cli.py` is the manual launcher
-(`--keys`, `--keys-file`, `--com`, `--raw`, `--timeout`).  The runtime is 9,597 bytes / 60 entries; the
+(`--keys`, `--keys-file`, `--com`, `--raw`, `--timeout`).  The runtime is 9,744 bytes / 62 entries; the
 rt_exec scaffold is at HDR=0x4000 / data 0x5000.  Items 1-4 below are
 independent of both tracks.
 

shell/Compiler.mod

@@ -147,6 +147,7 @@ CONST
    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 ;
    (* the sub-codes EmCrtSeq takes *)
    CrtClr = 0 ; CrtDl = 1 ; CrtDh = 2 ; CrtCaret = 3 ; CrtEol = 4 ;
    CrtLow = 5 ; CrtNorm = 6 ; CrtDelay = 7 ; CrtKey = 8 ;
@@ -174,6 +175,7 @@ CONST
       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 ;
@@ -254,6 +256,7 @@ TYPE
                                        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 *)
       END ;
 
    DirRec = RECORD  rng, chk : BOOLEAN  END ;
@@ -268,6 +271,7 @@ TYPE
          lo, hi : LONGINT ;         (* bounds, for a subrange/enum field *)
          fldFirst, fldLast : CARDINAL ;  (* nested record metadata *)
          arrIdx : CARDINAL ;
+         ptrElem : CARDINAL ;
       END ;
 
    ArrRec =
@@ -277,6 +281,11 @@ TYPE
          elem   : CARDINAL ;        (* element size in bytes *)
          ecls   : CARDINAL ;        (* element CLASS, for a subscripted value *)
          fldFirst, fldLast : CARDINAL ;  (* leaf record metadata *)
+         elemType : CARDINAL ;
+    fieldPtrElem : CARDINAL ;
+    variantBase, armRunning, armMax, savePosVar : CARDINAL ;
+    moreFields : BOOLEAN ;
+    tagName : ARRAY [0..MaxName] OF CHAR ;      (* pointer target / named element type *)
       END ;
 
 (* ---------------------------------------------------------------- *)
@@ -401,6 +410,8 @@ VAR
    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_WrReal   : CARDINAL ;  TU_RealWrite : CARDINAL ;  TU_RealFmt : CARDINAL ;
    TU_RealVal   : CARDINAL ;  TU_RealCmp : CARDINAL ;
    TU_RealAdd   : CARDINAL ;  TU_RealSub : CARDINAL ;
@@ -1689,6 +1700,12 @@ BEGIN Ebyte (80H) ; Ebyte (0E1H) ; Ebyte (VAL (BYTE, v)) END EmAndClImm ;
 PROCEDURE EmShrAx1 () ;
 BEGIN Ebyte (0D1H) ; Ebyte (0E8H) END EmShrAx1 ;        (* SHR AX,1 *)
 
+PROCEDURE EmShlAxCl () ;
+BEGIN Ebyte (0D3H) ; Ebyte (0E0H) END EmShlAxCl ;       (* SHL AX,CL *)
+
+PROCEDURE EmShrAxCl () ;
+BEGIN Ebyte (0D3H) ; Ebyte (0E8H) END EmShrAxCl ;       (* SHR AX,CL *)
+
 PROCEDURE EmMovBxi (v : CARDINAL) ;
 BEGIN Ebyte (0BBH) ; Eword (v MOD 10000H) END EmMovBxi ; (* MOV BX,imm16 *)
 
@@ -2603,6 +2620,15 @@ BEGIN
    RETURN symtab [r.idx].size
 END VarSize ;
 
+PROCEDURE IsCharArray (r : ERes) : BOOLEAN ;
+(* A fixed `array[..] of char', as opposed to a counted STRING. *)
+BEGIN
+   IF (r.cls # TArray) OR (r.arrIdx = 0) THEN
+      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).
 
@@ -2704,15 +2730,21 @@ VAR t : ERes ;
 BEGIN
    LOOP
       Skip () ;
-      IF (r.kind = 1) AND (symtab [r.idx].cls = TPtr) AND
-         (CurCh () = '^') THEN
-         (* Dereference in a statement/assignment path, which reaches ParseSub
-            without going through ParseVar.  The pointer word is the base
-            address; r.idx becomes the pointee TYPE symbol for array/record
-            metadata, exactly as in ParseVar. *)
+      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 := symtab [r.idx].elem ;
-         LoadSymVar (r.idx, symtab [r.idx].off, 2) ;
+         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 ;
@@ -2721,7 +2753,8 @@ BEGIN
          r.sz := symtab [p].size ;
          r.fldFirst := symtab [p].fldFirst ;
          r.fldLast := symtab [p].fldLast ;
-         r.arrIdx := symtab [p].arrIdx
+         r.arrIdx := symtab [p].arrIdx ;
+         r.ptrElem := symtab [p].elem
       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
@@ -2767,6 +2800,7 @@ BEGIN
          r.fldFirst := fields [fi].fldFirst ;
          r.fldLast := fields [fi].fldLast ;
          r.arrIdx := fields [fi].arrIdx ;
+         r.ptrElem := fields [fi].ptrElem ;
          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
@@ -2940,7 +2974,8 @@ BEGIN
             r.cls := arrs [ai].ecls ;
             r.fldFirst := arrs [ai].fldFirst ;
             r.fldLast := arrs [ai].fldLast ;
-            r.arrIdx := 0
+            r.arrIdx := 0 ;
+            r.ptrElem := arrs [ai].elemType
          ELSE
             ParseExpr (t) ;
             IF OK () THEN
@@ -2984,6 +3019,7 @@ BEGIN
          r.fldFirst := symtab [p].fldFirst ;
          r.fldLast := symtab [p].fldLast ;
          r.arrIdx := symtab [p].arrIdx ;
+         r.ptrElem := symtab [p].elem ;
          ParseSub (r) ;
          RETURN
       END
@@ -3012,6 +3048,7 @@ BEGIN
    r.fldFirst := symtab [r.idx].fldFirst ;
    r.fldLast := symtab [r.idx].fldLast ;
    r.arrIdx := symtab [r.idx].arrIdx ;
+   r.ptrElem := symtab [r.idx].elem ;
    ParseSub (r)
 END ParseVar ;
 
@@ -3084,24 +3121,42 @@ BEGIN
       IF (left.kind = 0) AND (right.kind = 0) THEN
          res.kind := 0 ;
           res.imm := BitAnd (left.imm, right.imm) ;
-         res.cls := TBool ;
+         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 ; res.cls := TBool ;
+      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) ;
-         res.cls := TBool ;
+         IF (left.cls = TBool) OR (right.cls = TBool) THEN
+            res.cls := TBool
+         ELSE
+            res.cls := left.cls
+         END ;
          RETURN
       END ;
       LoadPair (left, right) ;
       EmOrAxCx () ;
-      res.kind := 2 ; res.cls := TBool ;
+      res.kind := 2 ;
+      IF (left.cls = TBool) OR (right.cls = TBool) THEN
+         res.cls := TBool
+      ELSE
+         res.cls := left.cls
+      END ;
       RETURN
    END ;
    IF (left.kind = 0) AND (right.kind = 0) THEN
@@ -3134,6 +3189,8 @@ BEGIN
       OpAdd : EmAddAxCx ;
    |  OpSub : EmSubAxCx ;
    |  OpMul : EmMulAxCx ;
+   |  OpShl : EmShlAxCl ;
+   |  OpShr : EmShrAxCl ;
    |  TkDiv : EmIDivAxCx ;
    |  TkMod : EmIDivAxCx ; EmXchgAxDx ;
    ELSE
@@ -4257,6 +4314,10 @@ BEGIN
          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 ;
@@ -4394,6 +4455,7 @@ BEGIN
          r.fldFirst := fields [fi].fldFirst ;
          r.fldLast := fields [fi].fldLast ;
          r.arrIdx := fields [fi].arrIdx ;
+         r.ptrElem := fields [fi].ptrElem ;
          IF r.cls = TSet THEN
             r.setbase := fields [fi].elem ;
             r.setsize := fields [fi].size
@@ -4847,6 +4909,48 @@ BEGIN
       r.cls := TScalar ;
       r.chr := FALSE ;
       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) ;
+         RETURN
+      END ;
+      ParseExpr (r) ;
+      ExpectDelim (')', ENoSemi) ;
+      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) ;
+            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
@@ -5326,7 +5430,7 @@ END RealUnary ;
 PROCEDURE Assignment (r : ERes) ;
 (* ':=' already consumed by the caller; store expression into r *)
 VAR src : ERes ;
-    k, n, savePos : CARDINAL ;
+    k, n, savePos, scratch : CARDINAL ;
     sbuf : ARRAY [0..31] OF CHAR ;
     rbuf : ARRAY [0..5] OF CHAR ;
 BEGIN
@@ -5334,6 +5438,39 @@ BEGIN
       Err (EUnknown) ;
       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
@@ -5424,13 +5561,37 @@ BEGIN
          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])) ;
@@ -5448,6 +5609,17 @@ BEGIN
          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 () ;
@@ -5466,6 +5638,7 @@ BEGIN
                Err (ENoLib) ;
                RETURN
             END ;
+            EmPopDi () ;
             k := 0 ;
             WHILE k < 6 DO
                LoadSymVar (src.idx, (symtab [src.idx].off + src.boff + k) MOD 10000H, 1) ;
@@ -5852,8 +6025,8 @@ VAR arg : ERes ;
                                    a field width *)
     reading : BOOLEAN ;
     pushed : BOOLEAN ;
-    skipArg : BOOLEAN ;
-    n, p, scratch, cap : CARDINAL ;
+    skipArg, handled : BOOLEAN ;
+    k, n, p, scratch, cap : CARDINAL ;
     dummy, errV : ERes ;
 BEGIN
    which := symtab [idx].cls ;               (* BI_* *)
@@ -5871,11 +6044,19 @@ BEGIN
          allocation. *)
       IF MatchDelim ('(') THEN
          ParseExpr (arg) ;
-         IF OK () AND (arg.kind = 1) AND (arg.cls = TPtr) THEN
-            p := symtab [arg.idx].elem ;
+         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] *)
-            EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
+            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
@@ -5895,7 +6076,8 @@ BEGIN
          Dispose would need a real free list. *)
       IF MatchDelim ('(') THEN
          ParseExpr (arg) ;
-         IF OK () AND NOT ((arg.kind = 1) AND (arg.cls = TPtr)) THEN
+         IF OK () AND NOT (((arg.kind = 1) OR (arg.kind = 5))
+                          AND (arg.cls = TPtr)) THEN
             Err (ETypeErr)
          END ;
          ExpectDelim (')', ENoSemi)
@@ -6186,6 +6368,30 @@ BEGIN
       ExpectDelim (')', ENoSemi) ;
       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
@@ -6277,6 +6483,7 @@ BEGIN
                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
@@ -6306,6 +6513,28 @@ BEGIN
                      EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H) ;
                      DropC (EmCall (TU_FileReadln)) ;
                      EmAddSp (6)
+                  ELSIF OK () AND IsCharArray (dummy) AND (dummy.kind = 1) THEN
+                     (* Readln(F, Place): file_readln writes a counted string;
+                        use a scratch, prefill the tail with spaces, then copy
+                        the fixed width over the CHAR array. *)
+                     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 OK () THEN
                      Err (ETypeErr)
                   END ;
@@ -6394,7 +6623,44 @@ BEGIN
                ExpectDelim (')', ENoSemi) ;
                RETURN
             END ;
-            IF NOT skipArg THEN
+            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
@@ -7240,6 +7506,7 @@ BEGIN
          t.fldFirst := symtab [t.idx].fldFirst ;
          t.fldLast := symtab [t.idx].fldLast ;
          t.arrIdx := symtab [t.idx].arrIdx ;
+         t.ptrElem := symtab [t.idx].elem ;
          IF t.cls = TSet THEN
             (* The identifier-statement path does not go through ParseVar, so
                it must carry the same set metadata: Assignment's set branch
@@ -7276,6 +7543,11 @@ VAR tok : CARDINAL ;
     running, groupFirst, i, an, recStart : CARDINAL ;
     innerIdx, innerN, leafElem, leafCls, j : CARDINAL ;
     elemFldFirst, elemFldLast, fieldFldFirst, fieldFldLast, fieldArrIdx : CARDINAL ;
+    elemType : CARDINAL ;
+    fieldPtrElem : CARDINAL ;
+    variantBase, armRunning, armMax, savePosVar : CARDINAL ;
+    moreFields : BOOLEAN ;
+    tagName : ARRAY [0..MaxName] OF CHAR ;
     alo, ahi : ARRAY [0..3] OF LONGINT ;
     ecls2 : CARDINAL ;
 BEGIN
@@ -7406,6 +7678,10 @@ BEGIN
       innerIdx := newArrIdx ;
       elemFldFirst := recFldFirst ;
       elemFldLast := recFldLast ;
+      elemType := 0 ;
+      IF cls = TPtr THEN
+         elemType := e2
+      END ;
       IF (cls = TArray) AND (innerIdx > 0) THEN
          (* Flatten array-of-array: the outer symbol must index the same
             number of dimensions as `array[a,b]'.  A named element array
@@ -7415,6 +7691,7 @@ BEGIN
          leafCls := arrs [innerIdx - 1].ecls ;
          elemFldFirst := arrs [innerIdx - 1].fldFirst ;
          elemFldLast := arrs [innerIdx - 1].fldLast ;
+         elemType := arrs [innerIdx - 1].elemType ;
          innerN := arrs [innerIdx - 1].n
       ELSE
          leafElem := s2 ;
@@ -7438,6 +7715,7 @@ BEGIN
          arrs [arrTop].ecls := leafCls ;
          arrs [arrTop].fldFirst := elemFldFirst ;
          arrs [arrTop].fldLast := elemFldLast ;
+         arrs [arrTop].elemType := elemType ;
          i := 0 ;
          WHILE i < an DO
             arrs [arrTop].lo [i] := alo [i] ;
@@ -7503,6 +7781,141 @@ BEGIN
             Err (EUnknown) ;
             EXIT
          END ;
+         IF tok = TkCase THEN
+            (* Variant part: fields in all arms overlay at the same base.
+               The tag, when named, is an ordinary field before the arms. *)
+            DropB (MatchKey (tok)) ;
+            Skip () ;
+            tagName [0] := CHR (0) ;
+            savePosVar := srcPos ;
+            IF Alpha (CurCh ()) THEN
+               GetWord () ;
+               Skip () ;
+               IF CurCh () = ':' THEN
+                  CopyStr (tagName, wrd) ;
+                  DropCh (GetCh ()) ;
+                  ParseType (subcls, s2, e2) ;
+                  IF OK () THEN
+                     IF fldTop < MaxFields THEN
+                        CopyStr (fields [fldTop].name, tagName) ;
+                        fields [fldTop].cls := subcls ;
+                        fields [fldTop].size := s2 ;
+                        fields [fldTop].elem := e2 ;
+                        fields [fldTop].off := running ;
+                        fields [fldTop].fldFirst := recFldFirst ;
+                        fields [fldTop].fldLast := recFldLast ;
+                        fields [fldTop].arrIdx := newArrIdx ;
+                        fields [fldTop].ptrElem := 0 ;
+                        INC (fldTop) ;
+                        running := running + s2
+                     ELSE
+                        Err (ECompOvf)
+                     END
+                  ELSE
+                     RETURN
+                  END
+               ELSE
+                  srcPos := savePosVar ;
+                  ParseType (subcls, s2, e2) ;
+                  IF NOT OK () THEN
+                     RETURN
+                  END
+               END
+            ELSE
+               ParseType (subcls, s2, e2) ;
+               IF NOT OK () THEN
+                  RETURN
+               END
+            END ;
+            IF NOT (MatchKey (tok) AND (tok = TkOf)) THEN
+               Err (ENoSemi) ;
+               RETURN
+            END ;
+            variantBase := running ;
+            armMax := 0 ;
+            LOOP
+               Skip () ;
+               PeekKw (tok) ;
+               IF tok = TkEnd THEN
+                  EXIT
+               END ;
+               RdConst (lo, subcls, strf) ;
+               IF NOT MatchDelim (':') THEN
+                  Err (ENoSemi) ;
+                  RETURN
+               END ;
+               IF NOT MatchDelim ('(') THEN
+                  Err (ENoSemi) ;
+                  RETURN
+               END ;
+               armRunning := variantBase ;
+               moreFields := TRUE ;
+               WHILE moreFields AND (CurCh () # ')') DO
+                  groupFirst := fldTop ;
+                  LOOP
+                     Skip () ;
+                     IF NOT Alpha (CurCh ()) THEN
+                        Err (EUnknown) ;
+                        RETURN
+                     END ;
+                     GetWord () ;
+                     IF fldTop < MaxFields THEN
+                        CopyStr (fields [fldTop].name, wrd) ;
+                        fields [fldTop].off := 0 ;
+                        INC (fldTop)
+                     ELSE
+                        Err (ECompOvf)
+                     END ;
+                     IF NOT MatchDelim (',') THEN
+                        EXIT
+                     END
+                  END ;
+                  ExpectDelim (':', ENoSemi) ;
+                  ParseType (subcls, s2, e2) ;
+                  IF NOT OK () THEN
+                     RETURN
+                  END ;
+                  fieldFldFirst := recFldFirst ;
+                  fieldFldLast := recFldLast ;
+                  fieldArrIdx := newArrIdx ;
+                  fieldPtrElem := 0 ;
+                  IF subcls = TPtr THEN
+                     fieldPtrElem := e2
+                  END ;
+                  i := groupFirst ;
+                  WHILE i < fldTop DO
+                     fields [i].cls := subcls ;
+                     fields [i].size := s2 ;
+                     fields [i].elem := e2 ;
+                     fields [i].off := armRunning ;
+                     fields [i].lo := enumLo ;
+                     fields [i].hi := enumHi ;
+                     fields [i].fldFirst := fieldFldFirst ;
+                     fields [i].fldLast := fieldFldLast ;
+                     fields [i].arrIdx := fieldArrIdx ;
+                     fields [i].ptrElem := fieldPtrElem ;
+                     armRunning := armRunning + s2 ;
+                     INC (i)
+                  END ;
+                  IF MatchDelim (';') THEN
+                     (* another field group in this arm *)
+                  ELSE
+                     moreFields := FALSE
+                  END
+               END ;
+               ExpectDelim (')', ENoSemi) ;
+               IF armRunning - variantBase > armMax THEN
+                  armMax := armRunning - variantBase
+               END ;
+               IF MatchDelim (';') THEN
+                  (* another variant arm *)
+               ELSE
+                  EXIT
+               END
+            END ;
+            running := variantBase + armMax ;
+            (* the record's own END is read by the outer loop *)
+         ELSE
          (* the group's names, then ONE `: type' *)
          groupFirst := fldTop ;
          LOOP
@@ -7531,6 +7944,10 @@ BEGIN
          fieldFldFirst := recFldFirst ;
          fieldFldLast := recFldLast ;
          fieldArrIdx := newArrIdx ;
+         fieldPtrElem := 0 ;
+         IF subcls = TPtr THEN
+            fieldPtrElem := e2
+         END ;
          (* every name in the group gets the type and its own slot *)
          i := groupFirst ;
          WHILE i < fldTop DO
@@ -7543,6 +7960,7 @@ BEGIN
             fields [i].fldFirst := fieldFldFirst ;
             fields [i].fldLast := fieldFldLast ;
             fields [i].arrIdx := fieldArrIdx ;
+            fields [i].ptrElem := fieldPtrElem ;
             running := running + s2 ;
             INC (i)
          END ;
@@ -7550,7 +7968,8 @@ BEGIN
             Err (ENoSemi) ;
             RETURN
          END
-      END ;
+         END ;                         (* the variant IF *)
+      END ;                            (* the record field LOOP *)
       (* The field TYPES are parsed by ParseType, and its named-type arm
          copies the TYPE's field range into recFldFirst/recFldLast - for
          `Integer' that is 0/0.  So recFldFirst set at the top of this branch
@@ -7677,6 +8096,7 @@ VAR nm : ARRAY [0..MaxName] OF CHAR ;
     v : LONGINT ;
     off : CARDINAL ;
     first, i : CARDINAL ;
+    segAbs : BOOLEAN ;
 BEGIN
    LOOP
       Skip () ;                (* after the VAR keyword: skip blanks *)
@@ -7725,9 +8145,23 @@ BEGIN
             PeekKw (tok) ;
             IF tok = TkAbsolute THEN
                DropB (MatchKey (tok)) ;
+               Skip () ;
+               segAbs := FALSE ;
+               IF Alpha (CurCh ()) THEN
+                  (* Turbo's `Cseg:$80' / `Dseg:$80'.  Our globals carry
+                     LoadBias in their direct addresses, so subtract it from
+                     the requested absolute address. *)
+                  GetWord () ;
+                  ExpectDelim (':', ENoSemi) ;
+                  segAbs := TRUE
+               END ;
                IF (CurCh () = '$') OR (Digit (CurCh ())) THEN
                   RdIntConst (v) ;
-                  off := W16 (v)
+                  IF segAbs THEN
+                     off := W16 (v - VAL (LONGINT, LoadBias))
+                  ELSE
+                     off := W16 (v)
+                  END
                ELSE
                   Err (EUnknown) ;
                   off := 0
@@ -7757,6 +8191,38 @@ BEGIN
             END ;
             varspc := varspc + size * (symTop - first)
          ELSE
+            PeekKw (tok) ;
+            IF tok = TkAbsolute THEN
+               DropB (MatchKey (tok)) ;
+               Skip () ;
+               segAbs := FALSE ;
+               IF Alpha (CurCh ()) THEN
+                  GetWord () ;
+                  ExpectDelim (':', ENoSemi) ;
+                  segAbs := TRUE
+               END ;
+               IF (CurCh () = '$') OR (Digit (CurCh ())) THEN
+                  RdIntConst (v) ;
+                  IF segAbs THEN
+                     off := W16 (v - VAL (LONGINT, LoadBias))
+                  ELSE
+                     off := W16 (v)
+                  END
+               ELSE
+                  Err (EUnknown) ;
+                  off := 0
+               END ;
+               i := first ;
+               WHILE i < symTop DO
+                  symtab [i].cls := cls ; symtab [i].size := size ;
+                  symtab [i].elem := elem ; symtab [i].off := off ;
+                  symtab [i].fldFirst := recFldFirst ;
+                  symtab [i].fldLast := recFldLast ;
+                  symtab [i].arrIdx := newArrIdx ;
+                  symtab [i].local := FALSE ;
+                  INC (i)
+               END
+            ELSE
             IF (size > 2) AND (cls # TString) AND (cls # TRecord)
                AND (cls # TArray) AND (cls # TFile) AND (cls # TText)
                AND (cls # TUntyp) AND (cls # TReal) AND (cls # TSet) THEN
@@ -7788,6 +8254,7 @@ BEGIN
                INC (i)
             END ;
             locBytes := locBytes + size * (symTop - first)
+            END
          END
       END ;
       IF MatchDelim (',') THEN
@@ -8544,6 +9011,14 @@ BEGIN
    i := NewSym ("UPCASE", KBuiltin, BI_UpCase, 0, 0, 0, 0, FALSE) ;
    i := NewSym ("ORD", KBuiltin, BI_Ord, 0, 0, 0, 0, FALSE) ;
    symtab [i].defnd := TRUE ;
+   i := NewSym ("ROUND", KBuiltin, BI_Round, 0, 0, 0, 0, FALSE) ;
+   symtab [i].defnd := TRUE ;
+   i := NewSym ("TRUNC", KBuiltin, BI_Trunc, 0, 0, 0, 0, FALSE) ;
+   symtab [i].defnd := TRUE ;
+   i := NewSym ("MSDOS", KBuiltin, BI_Msdos, 0, 0, 0, 0, FALSE) ;
+   symtab [i].defnd := TRUE ;
+   i := NewSym ("INTR", KBuiltin, BI_Intr, 0, 0, 0, 0, FALSE) ;
+   symtab [i].defnd := TRUE ;
    i := NewSym ("SUCC", KBuiltin, BI_Succ, 0, 0, 0, 0, FALSE) ;
    i := NewSym ("PRED", KBuiltin, BI_Pred, 0, 0, 0, 0, FALSE) ;
    symtab [i].defnd := TRUE ;
@@ -8599,7 +9074,10 @@ BEGIN
       already read the console, so `Read(Kbd, Ch)' drops the file argument and
       reads a character exactly as `Read(Ch)' does. *)
    i := NewSym ("KBD", KVar, TText, FileVarSize, 1, 0, 0, FALSE) ;
-   symtab [i].isKbd := TRUE
+   symtab [i].isKbd := TRUE ;
+   (* LST is TP3's printer device.  The corpus uses it for listings; define
+      the identifier as a TEXT variable so Write(Lst, ...) type-checks. *)
+   i := NewSym ("LST", KVar, TText, FileVarSize, 1, 0, 0, FALSE)
 END DefBuiltins ;
 
 PROCEDURE Inittur () ;
@@ -8747,6 +9225,8 @@ BEGIN
    TU_WrBoolW  := RT_Entry (57) ;
    TU_WrStrW   := RT_Entry (58) ;
    TU_MemCopy  := RT_Entry (59) ;
+   TU_RealToInt := RT_Entry (60) ;
+   TU_Msdos    := RT_Entry (61) ;
    TU_WrReal   := RT_Entry (6) ;
    TU_RealWrite := RT_Entry (30) ;     (* fmtreal + padding + output *)
    TU_RealFmt   := RT_Entry (28) ;     (* fmtreal into a string variable *)

shell/Runtime.mod

@@ -1323,6 +1323,75 @@ BEGIN
    RetR
 END EmitWrStr ;
 
+PROCEDURE EmitMsdos ;
+(* Msdos(Registers): load AX/BX/CX/DX from the ten-word record at [BP+4],
+   execute INT 21h, and store the four result registers back.  The other
+   fields (BP/SI/DI/DS/ES/FLAGS) are accepted in the record but not touched. *)
+BEGIN
+   M ("msdos") ;
+   PushBp ; MovBpSp ;
+   PushBx ; PushCx ; PushDx ; PushDi ;
+   MovDiBp4 ;
+   LdAxDi ;
+   LdCxDiOff (2) ; MovBxCx ;
+   LdDxDiOff (4) ;
+   Int21 ;
+   StDiAx ;
+   StDiOffBx (2) ;
+   StDiOffDx (4) ;
+   PopDi ; PopDx ; PopCx ; PopBx ;
+   MovSpBp ; PopBp ; RetR
+END EmitMsdos ;
+
+PROCEDURE EmitRealToInt ;
+(* Convert the packed REAL at [BP+6] to a 16-bit INTEGER in AX.  [BP+4]
+   selects truncation (0) or rounding (1).  The 40-bit mantissa is
+   N = (2^39 + fraction), and the value is N * 2^(exponent-129-39); shifting
+   N right by 168-exponent gives the integer part, with the last carry out
+   being the round bit. *)
+BEGIN
+   M ("real_to_int") ;
+   PushBp ; MovBpSp ;
+   PushBx ; PushCx ; PushDx ; PushSi ; PushDi ;
+   MovSiBp6 ;
+   MovDiBp4 ;                           (* DI := mode *)
+   LdAlSi ;                            (* AL := exponent *)
+   CmpAl (81H) ; Jb8 ("rt_zero") ;
+   CmpAl (0A8H) ; Jae8 ("rt_zero") ;
+   LdCxSiOff (1) ; MovAxCx ;           (* AX := low mantissa word *)
+   LdCxSiOff (3) ; MovBxCx ;           (* BX := middle mantissa word *)
+   XorChCh ;                           (* CH := sign flag *)
+   LdDxSiOff (4) ;
+   TestDhImm (80H) ;
+   Je8 ("rt_pos") ;
+   MovChImm (1) ;
+   M ("rt_pos") ;
+   AndDhImm (7FH) ;
+   MovDlDh ; XorDhDh ;
+   B (80H) ; B (0CAH) ; B (80H) ;      (* OR DL,80H: implicit leading 1 *)
+   LdAlSi ;                            (* reload exponent after AX was built *)
+   MovClImm (0A8H) ; SubClAl ;         (* CL := 168-exponent; CH is sign *)
+   Jcxz8 ("rt_noshift") ;
+   M ("rt_loop") ;
+   ShrDx1 ; RcrBx1 ; B (0D1H) ; B (0D8H) ; DecCl ; Jne8 ("rt_loop") ;
+   Jmp8 ("rt_shifted") ;
+   M ("rt_noshift") ; Clc ;
+   M ("rt_shifted") ;
+   Jb8 ("rt_round") ;                  (* CF := last bit shifted out *)
+   Jmp8 ("rt_sign") ;
+   M ("rt_round") ;
+   MovDxDi ; CmpDx0 ; Je8 ("rt_sign") ; (* mode 0 = truncate *)
+   IncAx ;
+   M ("rt_sign") ;
+   TestChImm (1) ; Je8 ("rt_done") ;
+   NegAx ;
+   Jmp8 ("rt_done") ;
+   M ("rt_zero") ; XorAxAx ;
+   M ("rt_done") ;
+   PopDi ; PopSi ; PopDx ; PopCx ; PopBx ;
+   MovSpBp ; PopBp ; RetR
+END EmitRealToInt ;
+
 PROCEDURE EmitMemCopy ;
 (* Copy CX bytes from [BP+6] to [BP+4].  Used for whole record/array
    assignment.  ES is not reloaded: in this flat .COM ES = DS. *)
@@ -4246,7 +4315,8 @@ BEGIN
    EmitRealFromInt ; EmitRealAddSub ; EmitRealMul ;
    EmitRealCmp ; EmitRealInt ; EmitRealMath ; EmitRealConv ; EmitSetOps ;
    EmitStrDelete ; EmitStrInsert ; EmitFileOps ; EmitValReal ;
-   EmitWrCharW ; EmitWrBoolW ; EmitWrStrW ; EmitMemCopy ;
+   EmitWrCharW ; EmitWrBoolW ; EmitWrStrW ; EmitMemCopy ; EmitRealToInt ;
+   EmitMsdos ;
    EmitData ;
    FixUp ;
    SetStr (entNm [0], "initmem") ;
@@ -4309,6 +4379,8 @@ BEGIN
    SetStr (entNm [57], "wrboolw") ;
    SetStr (entNm [58], "wrstrw") ;
    SetStr (entNm [59], "memcopy") ;
+   SetStr (entNm [60], "real_to_int") ;
+   SetStr (entNm [61], "msdos") ;
    built := TRUE
 END RT_Build ;
 
@@ -4336,7 +4408,7 @@ BEGIN
    IF NOT built THEN
       RT_Build (0)
    END ;
-   IF i > 59 THEN
+   IF i > 61 THEN
       RETURN 0
    END ;
    RETURN rtBase + LblOff (entNm [i])

shell/tests/RtProbe.mod

@@ -108,7 +108,7 @@ END PENT ;
 
 PROCEDURE Main ;
 VAR i, n, base : CARDINAL ;
-    names : ARRAY [0..59] OF ARRAY [0..15] OF CHAR ;
+    names : ARRAY [0..61] OF ARRAY [0..15] OF CHAR ;
 BEGIN
    base := GetBase () ;
    RT_Build (base) ;
@@ -121,7 +121,7 @@ BEGIN
    PCARD (RT_Size ()) ; PS (" bytes") ; NL ;
    PS ("code ends at ") ; PCARD (RT_CodeEnd ()) ; NL ;
    i := 0 ;
-   WHILE i <= 59 DO
+   WHILE i <= 61 DO
       names [i] := "" ;
       INC (i)
    END ;
@@ -172,8 +172,10 @@ BEGIN
    names [57] := "wrboolw" ;
    names [58] := "wrstrw" ;
    names [59] := "memcopy" ;
+   names [60] := "real_to_int" ;
+   names [61] := "msdos" ;
    i := 0 ;
-   WHILE i <= 59 DO
+   WHILE i <= 61 DO
       PENT (i, names [i]) ;
       INC (i)
    END ;

shell/tests/audit_helpers.py

@@ -158,6 +158,8 @@ NON_ONE_LINE = {
         "EmitFileOps": COMP,
         "EmitWrCharW": COMP, "EmitWrBoolW": COMP, "EmitWrStrW": COMP,
         "EmitMemCopy": COMP,
+        "EmitRealToInt": COMP,
+        "EmitMsdos": COMP,
         "AddDiImm": COMP, "AddBxImm": COMP,
     },
     "Compiler.mod": {
@@ -460,6 +462,8 @@ PATTERNS = [
      "sbb", ["r:%(1)s", "r:%(2)s"], {0x18, 0x19, 0x1A, 0x1B}),
     (re.compile(r"^(Shl|Shr|Rcl|Rcr)(Al|Cl|Dl|Bl|Ah|Ch|Dh|Bh)Cl$"),
      None, ["r:%(2)s", "r:Cl"], {0xD2}),
+    (re.compile(r"^(Shl|Shr|Rcl|Rcr)(Ax|Bx|Cx|Dx|Si|Di|Bp|Sp)Cl$"),
+     None, ["r:%(2)s", "r:Cl"], {0xD3}),
     (re.compile(r"^Cbw$"), "cbw", [], {0x98}),
     (re.compile(r"^Imul(%s)$" % _ALT), "imul", ["r:%(1)s"], {0xF7}),
     # --- CMP reg,0 as a flag test (the 8086 has no OR reg,reg FCML can
@@ -773,7 +777,8 @@ def sweep(src, mod, verbose):
     # Its D_ offsets are asserted against this block by check_runtime.py's
     # golden, so "excluded from the name audit" is not "unchecked": the bytes
     # are pinned, only the name-to-opcode correspondence does not apply.
-    excluded = {"EmitData", "EmitFileOps", "EmitMemCopy"}
+    excluded = {"EmitData", "EmitFileOps", "EmitMemCopy", "EmitRealToInt",
+                 "EmitMsdos"}
     if verbose:
         print("-- %s" % mod)
         print("name                 bytes            FCML decode")
@@ -982,7 +987,8 @@ def sweep(src, mod, verbose):
     # Its D_ offsets are asserted against this block by check_runtime.py's
     # golden, so "excluded from the name audit" is not "unchecked": the bytes
     # are pinned, only the name-to-opcode correspondence does not apply.
-    excluded = {"EmitData", "EmitFileOps", "EmitMemCopy"}
+    excluded = {"EmitData", "EmitFileOps", "EmitMemCopy", "EmitRealToInt",
+                 "EmitMsdos"}
     strip = (lambda s: s[2:]) if mod != "Runtime.mod" else (lambda s: s)
     # The table is written in the names the audit uses (Runtime.mod's own
     # names, Compiler.mod's with the Em prefix already removed), so it is NOT

shell/tests/fixtures/calc_ladder.tsv

@@ -32,4 +32,4 @@
 # data base.  UpCase, set membership, strings, pointers, files, REAL
 # expressions/functions, recursion, forward definitions, Copy/Val/Delete/
 # Insert, local sets and the compact math runtime are all landed.
-CALC.PAS	OK	27484	19694
+CALC.PAS	OK	27488	19694

shell/tests/fixtures/expected.tsv

@@ -604,7 +604,7 @@ t79_strfield	OK	361	80
 #                   measured 6-byte MBF layout, symbol and DI stores, a
 #                   6-byte copy; the integer fields on either side pin the
 #                   width.  tests/check_realconst.py asserts the bytes.
-t80_realconst	OK	462	73
+t80_realconst	OK	466	73
 #   t81_upcase            UpCase on a CHAR: constant fold and the run-time
 #                   'a'..'z' fold, with the out-of-range values unchanged.
 t81_upcase	OK	273	6
@@ -766,3 +766,17 @@ t127_enumsub	OK	55	6
 t128_intreal	OK	147	27
 
 t129_setdiff	OK	169	7
+
+t130_ptrarray	OK	154	11
+
+t131_chararray	OK	127	10
+
+t132_readchararr	OK	183	266
+
+t133_roundtrunc	OK	164	19
+
+t134_shifts	OK	95	9
+
+t135_intrealassign	OK	114	19
+
+t136_variant	OK	53	8

shell/tests/fixtures/t130_ptrarray.out

@@ -0,0 +1 @@
+42

shell/tests/fixtures/t130_ptrarray.pas

@@ -0,0 +1,12 @@
+program ptrarray;
+type P = ^R;
+     R = record A : integer; end;
+var A : array[1..2] of P;
+    I : integer;
+begin
+  I := 1;
+  New(A[I]);
+  A[I]^.A := 42;
+  writeln(A[I]^.A);
+  Dispose(A[I])
+end.

shell/tests/fixtures/t131_chararray.out

@@ -0,0 +1 @@
+hi   

shell/tests/fixtures/t131_chararray.pas

@@ -0,0 +1,6 @@
+program chararr;
+var A : array[1..5] of char;
+begin
+  A := 'hi   ';
+  writeln(A)
+end.

shell/tests/fixtures/t132_readchararr.in

@@ -0,0 +1 @@
+hi

shell/tests/fixtures/t132_readchararr.out

@@ -0,0 +1 @@
+(hi   )

shell/tests/fixtures/t132_readchararr.pas

@@ -0,0 +1,6 @@
+program readchararr;
+var A : array[1..5] of char;
+begin
+  Readln(A);
+  Writeln('(', A, ')')
+end.

shell/tests/fixtures/t133_roundtrunc.out

@@ -0,0 +1,2 @@
+124
+125

shell/tests/fixtures/t133_roundtrunc.pas

@@ -0,0 +1,10 @@
+program rnd;
+var R : real;
+    I : integer;
+begin
+  R := 124.678;
+  I := Trunc(R);
+  writeln(I);
+  I := Round(R);
+  writeln(I)
+end.

shell/tests/fixtures/t134_shifts.out

@@ -0,0 +1 @@
+12 2

shell/tests/fixtures/t134_shifts.pas

@@ -0,0 +1,7 @@
+program shifts;
+var A, B : integer;
+begin
+  A := 3 shl 2;
+  B := 8 shr 2;
+  writeln(A, ' ', B)
+end.

shell/tests/fixtures/t135_intrealassign.out

@@ -0,0 +1 @@
+42.0

shell/tests/fixtures/t135_intrealassign.pas

@@ -0,0 +1,8 @@
+program intrealassign;
+var I : integer;
+    R : real;
+begin
+  I := 42;
+  R := I;
+  writeln(R:0:1)
+end.

shell/tests/fixtures/t136_variant.out

@@ -0,0 +1 @@
+65

shell/tests/fixtures/t136_variant.pas

@@ -0,0 +1,11 @@
+program variantrec;
+type V = record
+       case Flag : boolean of
+         TRUE  : (I : integer);
+         FALSE : (C : char)
+       end;
+var A : V;
+begin
+  A.I := 65;
+  writeln(A.I)
+end.

shell/tests/nonvacuity.sh

@@ -1934,7 +1934,7 @@ if python3 - <<'PYX'
 p = 'Compiler.mod'
 s = open(p).read()
 old = ('   i := NewSym ("KBD", KVar, TText, FileVarSize, 1, 0, 0, FALSE) ;\n'
-       '   symtab [i].isKbd := TRUE\n')
+       '   symtab [i].isKbd := TRUE ;\n')
 assert s.count(old) == 1, 'the KBD registration found %d times -- update this mutation' % s.count(old)
 open(p, 'w').write(s.replace(old, ''))
 PYX

shell/tests/rt_exec.py

@@ -118,7 +118,7 @@ ENTS = ["initmem", "progend", "stackchk", "wrint", "wrchar", "wrbool",
         "int_fmt", "val_int", "str_copy", "val_real", "real_abs",
         "real_sqrt", "real_ln", "real_exp", "real_sin", "real_cos",
         "real_arctan", "str_delete", "str_insert",
-        "wrcharw", "wrboolw", "wrstrw", "memcopy"]
+        "wrcharw", "wrboolw", "wrstrw", "memcopy", "real_to_int", "msdos"]
 
 # A call slot's flags, as rtdrv.s reads them.
 F_STACK = 1     # the argument goes on the stack, popped by the caller
@@ -919,6 +919,17 @@ def build_cases():
         dumpadr=SST_CAT,
         note="sum == CX is allowed; only sum > CX is the error")
 
+    # --- real_to_int: packed REAL -> INTEGER ----------------------------
+    blk42 = DSHIFT + 0x2230 + 16 * 6
+    add("real_to_int(42)",
+        [s2("real_to_int", 0, blk42 + LOAD_BIAS)],
+        dump=2, dumpbytes=struct.pack("<h", 42), dumpadr=AXOUT,
+        note="truncate the packed MBF to an integer")
+    add("real_round(42)",
+        [s2("real_to_int", 1, blk42 + LOAD_BIAS)],
+        dump=2, dumpbytes=struct.pack("<h", 42), dumpadr=AXOUT,
+        note="the same value, rounding mode")
+
     return cs