compiler: start TP3 language upgrades

Separate the remaining TP3 examples from the TP4/TP5 ones and remove the
latter from Sources.  Then add the first eight language fixes found by the
corpus:

- 63-character identifiers (MaxName)
- named labels and GOTO, including empty labels before END
- Addr() pointer expressions
- field widths for CHAR, BOOLEAN, STRING and string literals
- signed constants and negative array bounds
- nested array types flattened to one indexing shape
- forward pointer types such as ^Person before the record
- forward procedure parameter reuse without hiding later procedures
- NIL literals

Add t119-t124 for identifiers, labels, widths, Addr, nested arrays and
forward pointers.  Corpus is now 71 files: 54 compile, 17 remain.  CALC grows
to image 37,071 bytes; runtime is 9,570 bytes with 59 entries.

CALC-COMPILE.md

@@ -1262,7 +1262,7 @@ 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,393 bytes; the generated
+**CALC.PAS compiles and runs.**  The runtime is 9,570 bytes; the generated
 program is 27,498 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
@@ -1270,7 +1270,7 @@ 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
-36,894 bytes because the runtime, static links and code layout differ.
+37,071 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,7 +1317,7 @@ 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,498 B program + 9,393 B runtime = **36,891 B** | **OK, 4,069 B spare** |
+| `MaxCode` | 0A000h | 27,498 B program + 9,570 B runtime = **37,068 B** | **OK, 3,892 B spare** |
 | code window | `CodeMax = 0A000h`, capped by `MaxCode` | 27,498 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` |

CORPUS-TEST.md

@@ -76,8 +76,10 @@ Mixed archives — including `pascsrc.zip`, which also contains the 44 compiling
 TP3 examples — were deliberately kept.
 
 Before cleanup: **6,810 files**, **4,919 `.pas`**, **907 zips**.
-After cleanup: **1,740 files**, **80 `.pas`**, **858 zips**.
+After cleanup: **1,731 files**, **71 `.pas`**, **858 zips**.
 
-The remaining 80 Pascal files compile as **44 OK / 36 errors**; the errors are
-TP3-feature gaps such as `Word`, `LongInt`, `absolute`, `Printer`/`Dos`, and the
-missing include files, not the unit/Delphi noise.
+The remaining 71 Pascal files compile as **54 OK / 17 errors** after the first
+compiler upgrades (long identifiers, named labels, `Addr`, field widths,
+nested arrays, negative bounds, forward pointer types, `NIL`, and forward
+procedure parameters).  The remaining 17 are TP3-feature gaps, not
+unit/Delphi noise.

README.md

@@ -18,7 +18,7 @@ second copy of a status table is a claim about the world that expires silently
 and is never noticed expiring, so there is one now, and this file says where it
 is.
 
-In short, current as of `v-TP3-STRCONST`:
+In short, current as of `v-TP3-LANGUP`:
 
 - The shell and the WordStar-style editor are done.
 - The compiler front end and 8086 code generator are done for the language

SUMMARY.md

@@ -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,393 bytes / 56 entries; the
+(`--keys`, `--keys-file`, `--com`, `--raw`, `--timeout`).  The runtime is 9,570 bytes / 59 entries; the
 rt_exec scaffold is at HDR=0x4000 / data 0x5000.  Items 1-4 below are
 independent of both tracks.
 

shell/Compiler.mod

@@ -69,7 +69,7 @@ FROM Runtime IMPORT RT_Build, RT_Size, RT_Byte, RT_Entry, LoadBias ;
 
 CONST
    MaxLine   = 128 ;
-   MaxName   = 31 ;
+   MaxName   = 63 ;
 
    (* Size of the entry jump at image offset 0: E9 lo hi.  The jump's
       displacement is relative to the END of the jump, so every offset in the
@@ -394,6 +394,7 @@ VAR
    TU_StackChk : CARDINAL ;
    TU_WrInt    : CARDINAL ;  TU_WrIntW : CARDINAL ;
    TU_WrChar   : CARDINAL ;  TU_WrBool : CARDINAL ;
+   TU_WrCharW  : CARDINAL ;  TU_WrBoolW : CARDINAL ;  TU_WrStrW : CARDINAL ;
    TU_WrReal   : CARDINAL ;  TU_RealWrite : CARDINAL ;  TU_RealFmt : CARDINAL ;
    TU_RealVal   : CARDINAL ;  TU_RealCmp : CARDINAL ;
    TU_RealAdd   : CARDINAL ;  TU_RealSub : CARDINAL ;
@@ -2427,6 +2428,17 @@ BEGIN
    cls := TScalar ;
    v := 0 ;
    Skip () ;
+   IF CurCh () = '-' THEN
+      (* Signed ordinal constant, needed for array bounds such as
+         `array[-17..42] of real'.  ParseExpr already handles unary minus in
+         expressions; RdConst is the constant-only path and had no sign. *)
+      DropCh (GetCh ()) ;
+      RdConst (v, cls, isStr) ;
+      IF NOT isStr THEN
+         v := 0 - v
+      END ;
+      RETURN
+   END ;
    IF CurCh () = '$' THEN
       RdIntConst (v) ;
       cls := TScalar
@@ -4456,6 +4468,51 @@ BEGIN
       ParseSub (r) ;
       RETURN
    END ;
+   IF NameEq (wrd, "NIL") THEN
+      r.kind := 0 ;
+      r.cls := TPtr ;
+      r.imm := 0 ;
+      r.sz := 2 ;
+      RETURN
+   END ;
+   IF NameEq (wrd, "ADDR") THEN
+      (* Addr(x): the run-time address of x, as a pointer value in AX.  TP3
+         spells this Addr; the @ operator is a later Turbo spelling and is not
+         part of the TP3 subset yet. *)
+      IF NOT MatchDelim ('(') THEN
+         Err (ENoSemi) ;
+         RETURN
+      END ;
+      Skip () ;
+      IF NOT Alpha (CurCh ()) THEN
+         Err (EUnknown) ;
+         RETURN
+      END ;
+      GetWord () ;
+      ParseVar (r) ;
+      ExpectDelim (')', ENoSemi) ;
+      IF NOT OK () THEN
+         RETURN
+      END ;
+      IF r.kind = 5 THEN
+         EmMovAxDi ()
+      ELSIF r.kind = 1 THEN
+         IF symtab [r.idx].isVar THEN
+            LoadSymVar (r.idx, symtab [r.idx].off, 2)
+         ELSE
+            EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H) ;
+            EmPopAx ()
+         END
+      ELSE
+         Err (ETypeErr) ;
+         RETURN
+      END ;
+      r.kind := 2 ;
+      r.cls := TPtr ;
+      r.sz := 2 ;
+      r.idx := 0 ;
+      RETURN
+   END ;
    IF NOT Search (wrd, idx) THEN
       Err (EUnknown) ;
       RETURN
@@ -5039,19 +5096,24 @@ END ParseExpr ;
 (* ---------------------------------------------------------------- *)
 
 PROCEDURE ParseLabelStmt () ;
-(* numeric label definition 'n :' *)
+(* numeric or named label definition 'n :' / 'Name:' *)
 VAR n : CARDINAL ;
-    nm : ARRAY [0..9] OF CHAR ;
+    nm : ARRAY [0..MaxName] OF CHAR ;
     idx : CARDINAL ;
     i : CARDINAL ;
 BEGIN
-   n := 0 ;
-   WHILE Digit (CurCh ()) DO
-      n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ;
-      DropCh (GetCh ())
+   IF Alpha (CurCh ()) THEN
+      GetWord () ;
+      SaveWord (nm)
+   ELSE
+      n := 0 ;
+      WHILE Digit (CurCh ()) DO
+         n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ;
+         DropCh (GetCh ())
+      END ;
+      NumToName (n, nm)
    END ;
    ExpectDelim (':', ENoSemi) ;
-   NumToName (n, nm) ;
    IF Search (nm, idx) THEN
       IF symtab [idx].tag = KLabel THEN
          symtab [idx].defnd := TRUE ;
@@ -6304,8 +6366,9 @@ BEGIN
                         CALL wrtinl  <length byte> <characters...>
                      with no stack argument at all; wrtinl reads the length from the
                      return address and returns to just past the last character.
-                     Mirrored exactly, so the literal costs only its own characters
-                     in the code stream and nothing in the data segment. *)
+                     A following `:width' needs the ordinary address form, so
+                     wrstrw can pad it; the no-width path keeps the compact
+                     inline byte stream. *)
                   IF strLen [arg.strx] > 255 THEN
                      (* The length is one byte, so a literal of 256 characters or
                         more would wrap: 300 characters emitted behind a length of
@@ -6315,14 +6378,28 @@ BEGIN
                      Err (EConstRange) ;
                      RETURN
                   END ;
-                  DropC (EmCall (TU_WrInl)) ;
-                  Ebyte (VAL (BYTE, strLen [arg.strx])) ;
-                  n := 0 ;
-                  WHILE n < strLen [arg.strx] DO
-                     Ebyte (VAL (BYTE, ORD (strPool [strOff [arg.strx] + n]))) ;
-                     INC (n)
-                  END ;
-                  pushed := FALSE                (* nothing was pushed for this one *)
+                  IF MatchDelim (':') THEN
+                     (* A string literal with a field width: make its bytes an
+                        ordinary code-resident address, then pad before it. *)
+                     EmPushStrAddr (arg) ;
+                     ParseExpr (dummy) ;
+                     IF NOT OK () THEN
+                        RETURN
+                     END ;
+                     LoadAtom (dummy) ;
+                     EmPushAx () ;
+                     ent := TU_WrStrW ;
+                     argBytes := 4
+                  ELSE
+                     DropC (EmCall (TU_WrInl)) ;
+                     Ebyte (VAL (BYTE, strLen [arg.strx])) ;
+                     n := 0 ;
+                     WHILE n < strLen [arg.strx] DO
+                        Ebyte (VAL (BYTE, ORD (strPool [strOff [arg.strx] + n]))) ;
+                        INC (n)
+                     END ;
+                     pushed := FALSE             (* nothing was pushed for this one *)
+                  END
                ELSE
                   IF acls = TString THEN
                      (* A string *variable*.  Its value IS its address, so it is
@@ -6351,7 +6428,17 @@ BEGIN
                      ELSE
                         EmPushSymAddr (arg.idx, (symtab [arg.idx].off + arg.boff) MOD 10000H)
                      END ;
-                     ent := TU_WrStr
+                     ent := TU_WrStr ;
+                     IF MatchDelim (':') THEN
+                        ParseExpr (dummy) ;
+                        IF NOT OK () THEN
+                           RETURN
+                        END ;
+                        LoadAtom (dummy) ;
+                        EmPushAx () ;
+                        ent := TU_WrStrW ;
+                        argBytes := 4
+                     END
                   ELSE
                      IF acls = TReal THEN
                         (* A REAL is six bytes, so the writer takes its
@@ -6412,13 +6499,9 @@ BEGIN
                            (* Field width: `writeln(I:2)'.  TP3 evaluates the
                               width (CALC passes `FW', a variable), so it is
                               parsed and pushed AFTER the value: width at BP+4,
-                              value at BP+6.  Only an integer has a width entry
-                              yet - a CHAR/BOOLEAN/STRING width needs its own
-                              writer, and `:decimals' is the REAL form. *)
-                           IF (acls # TScalar) OR arg.chr THEN
-                              Err (ENoLib) ;
-                              RETURN
-                           END ;
+                              value at BP+6.  Char, BOOLEAN and integer each
+                              have their own width entry; a second colon is
+                              only legal for REAL, handled above. *)
                            ParseExpr (dummy) ;
                            IF NOT OK () THEN
                               RETURN
@@ -6429,7 +6512,13 @@ BEGIN
                               Err (ENoLib) ;
                               RETURN
                            END ;
-                           ent := TU_WrIntW ;
+                           IF arg.chr OR (acls = TChar) THEN
+                              ent := TU_WrCharW
+                           ELSIF acls = TBool THEN
+                              ent := TU_WrBoolW
+                           ELSE
+                              ent := TU_WrIntW
+                           END ;
                            argBytes := 4
                         END
                      END
@@ -6468,6 +6557,38 @@ BEGIN
    END
 END IoCall ;
 
+PROCEDURE LabelColonAhead () : BOOLEAN ;
+(* `Label:' is a statement label, but `Name;' is a procedure call.  Look
+   past an identifier and blanks without consuming input. *)
+VAR k : CARDINAL ;
+    ch : CHAR ;
+BEGIN
+   k := 0 ;
+   ch := PeekAhead (k) ;
+   IF NOT Alpha (ch) THEN
+      RETURN FALSE
+   END ;
+   WHILE AlphaNum (ch) DO
+      INC (k) ;
+      ch := PeekAhead (k)
+   END ;
+   WHILE ch = ' ' DO
+      INC (k) ;
+      ch := PeekAhead (k)
+   END ;
+   IF ch # ':' THEN
+      RETURN FALSE
+   END ;
+   (* `Name := ...' is an assignment, not a label definition. *)
+   INC (k) ;
+   ch := PeekAhead (k) ;
+   WHILE ch = ' ' DO
+      INC (k) ;
+      ch := PeekAhead (k)
+   END ;
+   RETURN ch # '='
+END LabelColonAhead ;
+
 PROCEDURE Statmnt () ;
 VAR tok : CARDINAL ;
     idx, i2 : CARDINAL ;
@@ -6483,10 +6604,9 @@ VAR tok : CARDINAL ;
     savedWith : CARDINAL ;
 BEGIN
    Skip () ;
-   IF Digit (CurCh ()) THEN
-      ParseLabelStmt () ;      (* consumed 'n' ':' *)
-      Statmnt () ;             (* 'n : statement' - the statement follows
-                                  the label directly, with no ';' between *)
+   IF Digit (CurCh ()) OR LabelColonAhead () THEN
+      ParseLabelStmt () ;      (* consumed the label and ':' *)
+      Statmnt () ;             (* the statement follows the label directly *)
       RETURN
    END ;
    IF NOT Alpha (CurCh ()) THEN
@@ -6860,10 +6980,17 @@ BEGIN
    ELSIF tok = TkGoto THEN
       v := 0 ;
       Skip () ;                  (* after the GOTO keyword: skip blanks *)
-      IF Digit (CurCh ()) THEN
+      IF Alpha (CurCh ()) THEN
+         GetWord () ;
+         SaveWord (nm)
+      ELSIF Digit (CurCh ()) THEN
          RdIntConst (v) ;
-         NumToName (W16 (v), nm) ;
-         IF Search (nm, idx) THEN
+         NumToName (W16 (v), nm)
+      ELSE
+         Err (EUnknown) ;
+         RETURN
+      END ;
+      IF Search (nm, idx) THEN
             IF symtab [idx].tag = KLabel THEN
                IF symtab [idx].defnd THEN
                   DropC (EmJmpNear (symtab [idx].goPos))
@@ -6874,13 +7001,10 @@ BEGIN
             ELSE
                Err (EUnknown)
             END
-         ELSE
-            idx := NewSym (nm, KLabel, TScalar, 0, 0, 0, 0, FALSE) ;
-            zj := EmJmpNear (0) ;
-            AddPend (0, idx, zj)
-         END
       ELSE
-         Err (EUnknown)
+         idx := NewSym (nm, KLabel, TScalar, 0, 0, 0, 0, FALSE) ;
+         zj := EmJmpNear (0) ;
+         AddPend (0, idx, zj)
       END
    ELSIF tok = TkExit THEN
       IF brkN = 0 THEN
@@ -7025,6 +7149,7 @@ VAR tok : CARDINAL ;
     isCharRange : BOOLEAN ;
     consumed : BOOLEAN ;
     running, groupFirst, i, an, recStart : CARDINAL ;
+    innerIdx, innerN, leafElem, leafCls, j : CARDINAL ;
     alo, ahi : ARRAY [0..3] OF LONGINT ;
     ecls2 : CARDINAL ;
 BEGIN
@@ -7044,9 +7169,16 @@ BEGIN
          RETURN
       END ;
       GetWord () ;
-      IF NOT Search (wrd, idx) OR (symtab [idx].tag # KType) THEN
-         Err (ESimpType) ;
-         RETURN
+      IF Search (wrd, idx) THEN
+         IF symtab [idx].tag # KType THEN
+            Err (ESimpType) ;
+            RETURN
+         END
+      ELSE
+         (* Forward type reference: `Next : ^Person' before the record is
+            declared.  Create a placeholder that DefType will fill. *)
+         idx := NewSym (wrd, KType, TNone, 0, 0, 0, 0, FALSE) ;
+         symtab [idx].fwd := TRUE
       END ;
       cls := TPtr ;
       size := 2 ;
@@ -7145,8 +7277,22 @@ BEGIN
       END ;
       ParseType (cls, s2, e2) ;
       ecls2 := cls ;
+      innerIdx := newArrIdx ;
+      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
+            (`Airplane = array[...] of Dog_Food') carries its shape in the
+            inner ArrRec; keep only the leaf element size and class here. *)
+         leafElem := arrs [innerIdx - 1].elem ;
+         leafCls := arrs [innerIdx - 1].ecls ;
+         innerN := arrs [innerIdx - 1].n
+      ELSE
+         leafElem := s2 ;
+         leafCls := ecls2 ;
+         innerN := 0
+      END ;
       cls := TArray ;
-      elem := s2 ;
+      elem := leafElem ;
       size := s2 ;
       i := 0 ;
       WHILE i < an DO
@@ -7154,18 +7300,24 @@ BEGIN
                              - VAL (LONGINT, W16 (alo [i])) + 1) ;
          INC (i)
       END ;
-      (* register the shape so indexing can scale by element size and subtract
-         each lower bound; the symbol points at this slot *)
-      IF arrTop < MaxArrs THEN
-         arrs [arrTop].n := an ;
-         arrs [arrTop].elem := s2 ;
-         arrs [arrTop].ecls := ecls2 ;
+      (* register the flattened shape so indexing can scale by leaf element
+         size and subtract each lower bound; the symbol points at this slot *)
+      IF (an + innerN <= 4) AND (arrTop < MaxArrs) THEN
+         arrs [arrTop].n := an + innerN ;
+         arrs [arrTop].elem := leafElem ;
+         arrs [arrTop].ecls := leafCls ;
          i := 0 ;
          WHILE i < an DO
             arrs [arrTop].lo [i] := alo [i] ;
             arrs [arrTop].hi [i] := ahi [i] ;
             INC (i)
          END ;
+         j := 0 ;
+         WHILE j < innerN DO
+            arrs [arrTop].lo [an + j] := arrs [innerIdx - 1].lo [j] ;
+            arrs [arrTop].hi [an + j] := arrs [innerIdx - 1].hi [j] ;
+            INC (j)
+         END ;
          newArrIdx := arrTop + 1 ;
          INC (arrTop)
       ELSE
@@ -7653,21 +7805,25 @@ BEGIN
 END DefConst ;
 
 PROCEDURE DefLabelPart () ;
-VAR nm : ARRAY [0..9] OF CHAR ;
+VAR nm : ARRAY [0..MaxName] OF CHAR ;
     n : CARDINAL ;
 BEGIN
    LOOP
       Skip () ;
-      IF NOT Digit (CurCh ()) THEN
+      IF Alpha (CurCh ()) THEN
+         GetWord () ;
+         SaveWord (nm)
+      ELSIF Digit (CurCh ()) THEN
+         n := 0 ;
+         WHILE Digit (CurCh ()) DO
+            n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ;
+            DropCh (GetCh ())
+         END ;
+         NumToName (n, nm)
+      ELSE
          Err (EUnknown) ;
          RETURN
       END ;
-      n := 0 ;
-      WHILE Digit (CurCh ()) DO
-         n := n * 10 + (ORD (CurCh ()) - ORD ('0')) ;
-         DropCh (GetCh ())
-      END ;
-      NumToName (n, nm) ;
       IF NOT Search (nm, n) THEN
          DropC (NewSym (nm, KLabel, TScalar, 0, 0, 0, 0, FALSE))
       END ;
@@ -8036,7 +8192,15 @@ BEGIN
    END ;
    HideLocals (nestMark) ;         (* parameters and locals stop here *)
    IF reusedFwd THEN
-      HideLocals (symtab [old].parmFirst)
+      (* Hide only the forward's parameter range.  HideLocals starts at
+         parmFirst and would also hide every procedure declared between the
+         forward and its definition; t120's `B' disappeared when A was
+         defined that way. *)
+      i := symtab [old].parmFirst ;
+      WHILE i < symtab [old].parmFirst + symtab [old].parmCount DO
+         symtab [i].level := 0FFFFH ;
+         INC (i)
+      END
    END ;
    lexnest := saveNest ;
    locFree := saveLoc ;
@@ -8068,13 +8232,25 @@ BEGIN
       END ;
       GetWord () ;
       SaveWord (nm) ;
-      DupTest (nm) ;
+      (* A type name may already exist as a forward placeholder created by
+         `Next : ^Person' before `Person = record'.  Reuse that entry; only a
+         real duplicate is an error. *)
+      IF Search (nm, tidx) AND (symtab [tidx].tag = KType)
+         AND (symtab [tidx].cls = TNone) THEN
+         (* fill the placeholder below *)
+      ELSE
+         DupTest (nm) ;
+         tidx := NewSym (nm, KType, TNone, 0, 0, 0, 0, FALSE)
+      END ;
       ExpectDelim ('=', ENoSemi) ;
       ParseType (cls, size, elem) ;
       IF NOT OK () THEN
          RETURN
       END ;
-      tidx := NewSym (nm, KType, cls, size, elem, 0, 0, FALSE) ;
+      symtab [tidx].cls := cls ;
+      symtab [tidx].size := size ;
+      symtab [tidx].elem := elem ;
+      symtab [tidx].fwd := FALSE ;
       IF cls = TEnum THEN
          (* the enumeration's bounds, set by ParseType, belong to the type - so
             `set of Attributes' can size its base (0..n-1, one byte) *)
@@ -8404,6 +8580,9 @@ BEGIN
    TU_WrInt    := RT_Entry (3) ;
    TU_WrChar   := RT_Entry (4) ;
    TU_WrBool   := RT_Entry (5) ;
+   TU_WrCharW  := RT_Entry (56) ;
+   TU_WrBoolW  := RT_Entry (57) ;
+   TU_WrStrW   := RT_Entry (58) ;
    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,107 @@ BEGIN
    RetR
 END EmitWrStr ;
 
+PROCEDURE EmitWrCharW ;
+(* CHAR with a field width: value at [BP+6], width at [BP+4]. *)
+BEGIN
+   M ("wrcharw") ;
+   PushBp ; MovBpSp ;
+   PushBx ; PushCx ; PushDx ;
+   MovAxBp4 ;
+   AddAxImm (0FFFFH) ;
+   CmpAx0 ;
+   Jle8 ("cw_body") ;
+   MovCxAx ;
+   M ("cw_pad") ;
+   MovAlD (ORD (' ')) ; MovDlAl ; MovAh (02H) ; Int21 ;
+   Loop8 ("cw_pad") ;
+   M ("cw_body") ;
+   MovBxBp6 ;
+   MovAlBl ;
+   MovDlAl ;
+   MovAh (02H) ;
+   Int21 ;
+   PopDx ; PopCx ; PopBx ;
+   MovSpBp ; PopBp ;
+   RetR
+END EmitWrCharW ;
+
+PROCEDURE EmitWrBoolW ;
+(* BOOLEAN with a field width: value at [BP+6], width at [BP+4]. *)
+BEGIN
+   M ("wrboolw") ;
+   PushBp ; MovBpSp ;
+   PushBx ; PushCx ; PushDx ;
+   MovAxBp6 ;
+   CmpAx0 ;
+   Jne8 ("bw_true") ;
+   MovBxVx (D_FALSE) ;
+   MovCxImm (5) ;
+   J8 ("bw_have") ;
+   M ("bw_true") ;
+   MovBxVx (D_TRUE) ;
+   MovCxImm (4) ;
+   M ("bw_have") ;
+   PushCx ;
+   MovAxBp4 ;
+   SubAxCx ;
+   CmpAx0 ;
+   Jle8 ("bw_body") ;
+   MovCxAx ;
+   M ("bw_pad") ;
+   MovAlD (ORD (' ')) ; MovDlAl ; MovAh (02H) ; Int21 ;
+   Loop8 ("bw_pad") ;
+   M ("bw_body") ;
+   PopCx ;
+   Jcxz8 ("bw_done") ;
+   M ("bw_out") ;
+   LdAlBx ;
+   MovDlAl ;
+   MovAh (02H) ;
+   Int21 ;
+   IncBx ;
+   Loop8 ("bw_out") ;
+   M ("bw_done") ;
+   PopDx ; PopCx ; PopBx ;
+   MovSpBp ; PopBp ;
+   RetR
+END EmitWrBoolW ;
+
+PROCEDURE EmitWrStrW ;
+(* STRING with a field width: address at [BP+6], width at [BP+4]. *)
+BEGIN
+   M ("wrstrw") ;
+   PushBp ; MovBpSp ;
+   PushBx ; PushCx ; PushDx ;
+   MovBxBp6 ;
+   XorCxCx ;
+   MovClBx ;
+   IncBx ;
+   PushCx ;
+   MovAxBp4 ;
+   SubAxCx ;
+   CmpAx0 ;
+   Jle8 ("sw_body") ;
+   MovCxAx ;
+   M ("sw_pad") ;
+   MovAlD (ORD (' ')) ; MovDlAl ; MovAh (02H) ; Int21 ;
+   Loop8 ("sw_pad") ;
+   M ("sw_body") ;
+   PopCx ;
+   Jcxz8 ("sw_done") ;
+   M ("sw_out") ;
+   LdAlBx ;
+   MovDlAl ;
+   MovAh (02H) ;
+   Int21 ;
+   IncBx ;
+   Loop8 ("sw_out") ;
+   M ("sw_done") ;
+   PopDx ; PopCx ; PopBx ;
+   MovSpBp ; PopBp ;
+   RetR
+END EmitWrStrW ;
+
 PROCEDURE EmitWrBool ;
 (* 4, not 2, for the reason given on CmpArg4W0: BP is pushed before it is
    borrowed, so the argument is four bytes up.  POP BP before the RET, and
@@ -4123,6 +4224,7 @@ BEGIN
    EmitRealFromInt ; EmitRealAddSub ; EmitRealMul ;
    EmitRealCmp ; EmitRealInt ; EmitRealMath ; EmitRealConv ; EmitSetOps ;
    EmitStrDelete ; EmitStrInsert ; EmitFileOps ; EmitValReal ;
+   EmitWrCharW ; EmitWrBoolW ; EmitWrStrW ;
    EmitData ;
    FixUp ;
    SetStr (entNm [0], "initmem") ;
@@ -4181,6 +4283,9 @@ BEGIN
    SetStr (entNm [53], "real_arctan") ;
    SetStr (entNm [54], "str_delete") ;
    SetStr (entNm [55], "str_insert") ;
+   SetStr (entNm [56], "wrcharw") ;
+   SetStr (entNm [57], "wrboolw") ;
+   SetStr (entNm [58], "wrstrw") ;
    built := TRUE
 END RT_Build ;
 
@@ -4208,7 +4313,7 @@ BEGIN
    IF NOT built THEN
       RT_Build (0)
    END ;
-   IF i > 55 THEN
+   IF i > 58 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..55] OF ARRAY [0..15] OF CHAR ;
+    names : ARRAY [0..58] 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 <= 55 DO
+   WHILE i <= 58 DO
       names [i] := "" ;
       INC (i)
    END ;
@@ -168,8 +168,11 @@ BEGIN
    names [53] := "real_arctan" ;
    names [54] := "str_delete" ;
    names [55] := "str_insert" ;
+   names [56] := "wrcharw" ;
+   names [57] := "wrboolw" ;
+   names [58] := "wrstrw" ;
    i := 0 ;
-   WHILE i <= 55 DO
+   WHILE i <= 58 DO
       PENT (i, names [i]) ;
       INC (i)
    END ;

shell/tests/audit_helpers.py

@@ -156,6 +156,7 @@ NON_ONE_LINE = {
         # bytes are pinned by rt_exec's file_assign case and the runtime
         # golden; the name grammar cannot read a whole routine.
         "EmitFileOps": COMP,
+        "EmitWrCharW": COMP, "EmitWrBoolW": COMP, "EmitWrStrW": COMP,
         "AddDiImm": COMP, "AddBxImm": COMP,
     },
     "Compiler.mod": {

shell/tests/fixtures/expected.tsv

@@ -744,3 +744,15 @@ t116_nestedstr	OK	301	263
 t117_charfor	OK	88	6
 
 t118_strconstarray	OK	93	5
+
+t121_widths	OK	208	18
+
+t119_longname	OK	53	7
+
+t120_labels	OK	95	7
+
+t122_addr	OK	91	9
+
+t123_nestedarray	OK	79	19
+
+t124_forwardptr	OK	94	7

shell/tests/fixtures/t119_longname.out

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

shell/tests/fixtures/t119_longname.pas

@@ -0,0 +1,6 @@
+program This_Program_Name_Is_Long_But_Still_Within_TP3_Limit;
+var This_Variable_Name_Is_Also_Long_But_Still_Legal_In_TP3 : integer;
+begin
+  This_Variable_Name_Is_Also_Long_But_Still_Legal_In_TP3 := 42;
+  writeln(This_Variable_Name_Is_Also_Long_But_Still_Legal_In_TP3)
+end.

shell/tests/fixtures/t120_labels.out

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

shell/tests/fixtures/t120_labels.pas

@@ -0,0 +1,11 @@
+program named_labels;
+label Again, Done;
+var I : integer;
+begin
+  I := 0;
+Again:
+  I := I + 1;
+  if I < 3 then goto Again;
+  writeln(I);
+Done: ;
+end.

shell/tests/fixtures/t121_widths.out

@@ -0,0 +1,5 @@
+  Z|
+  TRUE|
+  hi|
+  x|
+   |

shell/tests/fixtures/t121_widths.pas

@@ -0,0 +1,14 @@
+program widths;
+var c : char;
+    b : boolean;
+    s : string[10];
+begin
+  c := 'Z';
+  b := true;
+  s := 'hi';
+  writeln(c:3, '|');
+  writeln(b:6, '|');
+  writeln(s:4, '|');
+  writeln('x':3, '|');
+  writeln('':3, '|')
+end.

shell/tests/fixtures/t122_addr.out

@@ -0,0 +1,2 @@
+17
+23

shell/tests/fixtures/t122_addr.pas

@@ -0,0 +1,10 @@
+program address_test;
+var X : integer;
+    P : ^integer;
+begin
+  X := 17;
+  P := Addr(X);
+  writeln(P^);
+  P^ := 23;
+  writeln(X)
+end.

shell/tests/fixtures/t123_nestedarray.out

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

shell/tests/fixtures/t123_nestedarray.pas

@@ -0,0 +1,8 @@
+program nested_array_test;
+var A : array[1..2] of array[1..2] of integer;
+    B : array[-1..1] of integer;
+begin
+  A[2,1] := 42;
+  B[-1] := 7;
+  writeln(A[2,1], ' ', B[-1])
+end.

shell/tests/fixtures/t124_forwardptr.out

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

shell/tests/fixtures/t124_forwardptr.pas

@@ -0,0 +1,14 @@
+program forward_pointer_test;
+type PNode = ^Node;
+     Node = record
+       Value : integer;
+       Next  : PNode;
+     end;
+var P : PNode;
+begin
+  New(P);
+  P^.Value := 42;
+  P^.Next := nil;
+  writeln(P^.Value);
+  Dispose(P)
+end.

shell/tests/nonvacuity.sh

@@ -2076,7 +2076,7 @@ cp "$SAVED_C" Compiler.mod
 # width and still cleans up four bytes, so wrint reads the WIDTH as its value
 # and the stack stays balanced: t76 prints the widths, not the numbers.
 cp "$SAVED_C" Compiler.mod
-if mutate_compiler 's|ent := TU_WrIntW ;|ent := TU_WrInt ;|'; then
+if mutate_compiler 's|ent := TU_WrIntW|ent := TU_WrInt|'; then
     if rebuild_compiler; then
         expect_red "t76 red when a width calls the plain integer writer"             "FAIL" python3 tests/run_com_exec.py t76_width
     else

shell/tests/rt_exec.py

@@ -117,7 +117,8 @@ ENTS = ["initmem", "progend", "stackchk", "wrint", "wrchar", "wrbool",
         "ioresult", "io_store", "heap_new", "file_eof", "file_readln",
         "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"]
+        "real_arctan", "str_delete", "str_insert",
+        "wrcharw", "wrboolw", "wrstrw"]
 
 # A call slot's flags, as rtdrv.s reads them.
 F_STACK = 1     # the argument goes on the stack, popped by the caller