Browse Source

compiler: set assignment to a record field, and `in' on a set field

CALC.INC:161, the first statement in `with Sheet[I,J] do', is

    CellStatus := [Txt];

CellStatus is `set of Attributes' (0..5, ONE byte).  The assignment used
to reach LoadAtom, which refuses a set.  It now parses the constructor
with the TARGET's base and size - so `[Txt]' is a one-byte set, not the
default 32-byte set of Char - and stores the known bytes at symbol+boff
or through DI for a run-time-indexed element.

Observing it needed `in': a CODE-resident set (an inline literal or a
typed constant) still folds at compile time, but a set FIELD is tested
at run time by loading its byte and masking the element's bit.  The
distinction is the offset: a typed constant lives below dataBase, a
global's data does not; locals are frame offsets.  A field selected from
an array/record also had to record its SETOFF at selection time -
ParseVar ran while the class was still TArray, so the base offset was
stale and `Locked in sh[2,3].Status' read absolute address 15.

t78_setfield: a WITH set assignment (DI), a constant-index element set
assignment, membership true and false on both, and N set before the set
and read after it - a store that used the default 32-byte length would
run over N.  Non-vacuity makes the store write 32 bytes, and drops the
field's set base offset; both redden only at execution.

The ladder moves 15131 -> 15201, now `Contents := '': a STRING
assignment to a record field addressed through DI.
Eric Streit 1 day ago
parent
commit
7628b0b511

+ 114 - 2
shell/Compiler.mod

@@ -1389,6 +1389,22 @@ BEGIN
    EmPushDi ()
 END EmStoreVarIndPrep ;
 
+PROCEDURE EmStDiImm (off, v : CARDINAL) ;
+(* MOV byte [DI+off],imm8: one byte of a set constructor stored through a
+   DI-addressed record field.  Sets are at most 32 bytes, so disp8 is enough. *)
+BEGIN
+   Ebyte (0C6H) ; Ebyte (45H) ; Ebyte (VAL (BYTE, off)) ; Ebyte (VAL (BYTE, v))
+END EmStDiImm ;
+
+PROCEDURE EmLdAlDiOff (off : CARDINAL) ;
+(* MOV AL,[DI+off]: the byte of a set variable that holds an element's bit. *)
+BEGIN
+   Ebyte (8AH) ; Ebyte (45H) ; Ebyte (VAL (BYTE, off))
+END EmLdAlDiOff ;
+
+PROCEDURE EmAndAlImm (v : CARDINAL) ;
+BEGIN Ebyte (24H) ; Ebyte (VAL (BYTE, v)) END EmAndAlImm ;  (* AND AL,imm8 *)
+
 PROCEDURE EmStoreInd (nbytes : CARDINAL) ;
 (* [DI] := AL/WORD, after POP DI - the companion of EmStoreVarIndPrep. *)
 BEGIN
@@ -2333,7 +2349,15 @@ BEGIN
                            + VAL (LONGINT, fields [fi].off)) ;
          END ;
          r.cls := fields [fi].cls ;
-         r.sz := fields [fi].size
+         r.sz := fields [fi].size ;
+         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
+               base offset has to be recorded now. *)
+            r.setoff := symtab [r.idx].off ;
+            r.setbase := fields [fi].elem ;
+            r.setsize := fields [fi].size
+         END
       ELSIF CurCh () = '[' THEN
          DropCh (GetCh ()) ;
          IF symtab [r.idx].cls = TString THEN
@@ -2969,7 +2993,8 @@ PROCEDURE FoldSetIn (left, right : ERes ; VAR res : ERes) ;
    answers at run time (AH > 255 -> FALSE, else test the bit).  A run-time
    element or a run-time set is still ENoLib - that is the next milestone, and
    it must stay LOUD rather than silently answer wrong. *)
-VAR off, base, size, rel, bidx, bit, m, o : CARDINAL ; isIn : BOOLEAN ;
+VAR off, base, size, rel, bidx, bit, m, o : CARDINAL ;
+    isIn, foldable : BOOLEAN ;
 BEGIN
    res.kind := 0 ;
    res.imm := 0 ;
@@ -2979,6 +3004,50 @@ BEGIN
       Err (ENoLib) ;
       RETURN
    END ;
+   (* A code-resident set (an inline literal or a typed constant) folds at
+      compile time.  A DATA set - a record field, local or global, or one
+      addressed through DI - must be tested at run time: its byte is in the
+      image's data area, not in cbuf.  A typed constant's offset is below
+      dataBase; a global's is at or above it. *)
+   foldable := (right.kind = 7) ;
+   IF (right.kind = 1) AND NOT symtab [right.idx].local
+      AND (right.setoff + right.boff < dataBase) THEN
+      foldable := TRUE
+   END ;
+   IF NOT foldable THEN
+      IF (left.imm >= 0) AND (left.imm <= 255) THEN
+         base := right.setbase ; size := right.setsize ;
+         rel := VAL (CARDINAL, left.imm) ;
+         IF rel >= base THEN
+            bidx := (rel - base) DIV 8 ;
+            IF bidx < size THEN
+               bit := (rel - base) MOD 8 ;
+               m := 1 ;
+               WHILE bit > 0 DO
+                  m := m * 2 ; DEC (bit)
+               END ;
+               IF right.kind = 5 THEN
+                  EmLdAlDiOff (bidx)
+               ELSIF right.kind = 1 THEN
+                  EmLoadVar (symtab [right.idx].local,
+                             (right.setoff + right.boff + bidx) MOD 10000H, 1)
+               ELSE
+                  Err (ENoLib) ;
+                  RETURN
+               END ;
+               EmAndAlImm (m) ;
+               EmMovAh0 () ;
+               EmOrAxAx () ;
+               EmRelSetcc (2) ;         (* SETNE: the bit was set *)
+               res.kind := 2 ;
+               res.cls := TBool ;
+               RETURN
+            END
+         END
+      END ;
+      res.imm := 0 ;
+      RETURN
+   END ;
    isIn := FALSE ;
    IF (left.imm >= 0) AND (left.imm <= 255) THEN
       off := right.setoff ; base := right.setbase ; size := right.setsize ;
@@ -3403,12 +3472,17 @@ BEGIN
             r.kind := 5
          ELSE
             r.kind := 1 ;
+            r.setoff := symtab [withIdx [w]].off ;
             r.boff := W16 (VAL (LONGINT, withBoff [w])
                            + VAL (LONGINT, fields [fi].off))
          END ;
          r.idx := withIdx [w] ;
          r.cls := fields [fi].cls ;
          r.sz := fields [fi].size ;
+         IF r.cls = TSet THEN
+            r.setbase := fields [fi].elem ;
+            r.setsize := fields [fi].size
+         END ;
          r.chr := FALSE ;
          RETURN TRUE
       END
@@ -3802,11 +3876,49 @@ PROCEDURE Assignment (r : ERes) ;
 (* ':=' already consumed by the caller; store expression into r *)
 VAR src : ERes ;
     k, n : CARDINAL ;
+    sbuf : ARRAY [0..31] OF CHAR ;
 BEGIN
    IF (r.kind # 1) AND (r.kind # 5) THEN
       Err (EUnknown) ;
       RETURN
    END ;
+   IF r.cls = TSet THEN
+      (* `field := [elements]'.  The constructor's TYPE comes from the target:
+         CALC's CellStatus is `set of Attributes' (one byte), not the default
+         32-byte `set of Char' an untyped literal would become.  The bytes are
+         known at compile time; store them at symbol+boff or through DI. *)
+      IF (r.setsize = 0) OR (r.setsize > 32) THEN
+         Err (ENoLib) ;
+         RETURN
+      END ;
+      Skip () ;
+      IF CurCh () # '[' THEN
+         (* set := set, or a set expression: the next increment *)
+         Err (ENoLib) ;
+         RETURN
+      END ;
+      IF NOT RdSetLiteral (r.setbase, r.setsize, sbuf) THEN
+         RETURN
+      END ;
+      IF r.kind = 5 THEN
+         k := 0 ;
+         WHILE k < r.setsize DO
+            EmStDiImm (k, ORD (sbuf [k])) ;
+            INC (k)
+         END
+      ELSIF r.kind = 1 THEN
+         k := 0 ;
+         WHILE k < r.setsize DO
+            EmMovAxi (ORD (sbuf [k])) ;
+            EmStoreVar (symtab [r.idx].local,
+                        (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ;
+            INC (k)
+         END
+      ELSE
+         Err (ENoLib)
+      END ;
+      RETURN
+   END ;
    IF (r.kind = 5) AND (r.cls = TString) THEN
       (* A whole string field of a run-time-indexed record element: the
          string paths address by symbol+boff, which is not this element.

+ 6 - 0
shell/tests/audit_helpers.py

@@ -162,6 +162,12 @@ NON_ONE_LINE = {
         "AddDiImm": COMP,
         "LdDiGlob": COMP,
         "StDiGlob": COMP,
+        # Set-field helpers: store one constructor byte through DI
+        # (StDiImm), and test one element's bit in a DI-addressed set
+        # (LdAlDiOff + AndAlImm).  t78_setfield pins both.
+        "StDiImm": COMP,
+        "LdAlDiOff": COMP,
+        "AndAlImm": COMP,
     },
 }
 # The Vx family is NOT here: those four are audited by audit_vx_helpers,

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

@@ -25,10 +25,10 @@
 # positions shift — which is exactly why this must be a measured number, not a
 # remembered one.
 #
-# Current rung (2026-10-21): `CellStatus := [Txt]' in CALC.INC's Init - the
-# first statement inside `with Sheet[I,J] do'.  WITH, n-dimensional array
-# subscripts, and fields through a DI-addressed element landed (t77_with),
-# moving 15026 -> 15131.  The blocker is now a SET assignment to a record
-# field: the RHS set constructor is still a 32-byte `set of Char' literal and
-# LoadAtom refuses a set, and no counted-field store through DI exists.
-CALC.PAS	ERR	102	15131
+# Current rung (2026-10-21): `Contents := ''` in CALC.INC's Init - the second
+# statement inside `with Sheet[I,J] do'.  Set-field assignment and run-time
+# membership landed (t78_setfield), moving 15131 -> 15201.  The blocker is now
+# a STRING assignment to a record field addressed through DI: the counted
+# string copy must write <len><chars> to the DI address (truncated to the
+# field's capacity).
+CALC.PAS	ERR	102	15201

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

@@ -589,3 +589,8 @@ t76_width	OK	258	9
 #                   element, and a 2-D run-time element (row stride, base
 #                   parked in a data slot); 2-D and mixed subscripts.
 t77_with	OK	390	34
+#   t78_setfield           a SET field of a record: assignment typed by the
+#                   target (one byte, not the 32-byte default), through WITH
+#                   (DI) and a constant-index element; `in' on a variable
+#                   set loads the byte and masks the bit at run time.
+t78_setfield	OK	279	23

+ 6 - 0
shell/tests/fixtures/t78_setfield.out

@@ -0,0 +1,6 @@
+txt
+not-locked
+l2
+nt2
+5
+7

+ 51 - 0
shell/tests/fixtures/t78_setfield.pas

@@ -0,0 +1,51 @@
+program t78_setfield;
+
+{ t78 -- a SET field of a record: assignment and membership.
+
+  CALC.INC:161 is the first statement inside `with Sheet[I,J] do':
+
+      CellStatus := [Txt];
+
+  CellStatus is `set of Attributes' (0..5, so ONE byte), NOT the default
+  32-byte `set of Char' that an untyped constructor becomes.  The target
+  supplies the base and size; the constructor's bytes are known at compile
+  time and are stored at symbol+boff (a constant-index element) or through DI
+  (a run-time-indexed one).
+
+  `in' is the observation: a CODE-resident set (literal or typed constant)
+  still folds at compile time, while a set FIELD is tested at run time by
+  loading its byte and masking the element's bit. }
+
+type
+   Attr = (Constant, Formula, Txt, OverWritten, Locked, Calculated);
+   Cell = record
+      Status : set of Attr;
+      N : integer;
+   end;
+
+var
+   sh : array [1..2, 1..3] of Cell;
+
+begin
+   with sh[1,1] do
+   begin
+      Status := [Txt];
+      N := 5
+   end;
+   with sh[1,1] do
+      if Txt in Status then writeln ('txt') else writeln ('no-txt');
+   with sh[1,1] do
+      if Locked in Status then writeln ('locked') else writeln ('not-locked');
+
+   (* N sits immediately after the one-byte Status.  Set it FIRST, then the
+      set: a store that used the default 32-byte length would run over N and
+      zero it. *)
+   sh[2,3].N := 7;
+   sh[2,3].Status := [Locked, Calculated];
+   if Locked in sh[2,3].Status then writeln ('l2') else writeln ('nl2');
+   if Txt in sh[2,3].Status then writeln ('t2') else writeln ('nt2');
+
+   (* the fields after the set were not clobbered *)
+   writeln (sh[1,1].N);
+   writeln (sh[2,3].N)
+end.

+ 35 - 0
shell/tests/nonvacuity.sh

@@ -1924,6 +1924,41 @@ else
 fi
 cp "$SAVED_C" Compiler.mod
 
+# --- a set field's constructor is sized by the TARGET ---------------------
+# Write the default 32-byte set-of-Char length instead of the field's one
+# byte: the store runs past Status into N and the neighbours.  t78 reads N
+# back, so the overrun is visible.
+cp "$SAVED_C" Compiler.mod
+if mutate_compiler 's|         WHILE k < r.setsize DO|         WHILE k < 32 DO|'; then
+    if rebuild_compiler; then
+        expect_red "t78 red when a set field stores 32 bytes, not its size"             "FAIL" python3 tests/run_com_exec.py t78_setfield
+    else
+        echo "  FAIL: the compiler would not rebuild with the 32-byte store"
+        fail=$((fail + 1))
+    fi
+else
+    echo "  BROKEN CASE: the set-size mutation did not apply"
+    fail=$((fail + 1))
+fi
+cp "$SAVED_C" Compiler.mod
+
+# --- a field's set base offset is the ARRAY/RECORD's ----------------------
+# `in' reads setoff + boff.  Forgetting the symbol's base (setoff := 0) makes
+# sh[2,3].Status read absolute address 15 instead of sh+15.
+cp "$SAVED_C" Compiler.mod
+if mutate_compiler 's|            r.setoff := symtab \[r.idx\].off ;|            r.setoff := 0 ;|'; then
+    if rebuild_compiler; then
+        expect_red "t78 red when a field's set base offset is dropped"             "FAIL" python3 tests/run_com_exec.py t78_setfield
+    else
+        echo "  FAIL: the compiler would not rebuild without the set base"
+        fail=$((fail + 1))
+    fi
+else
+    echo "  BROKEN CASE: the set-base mutation did not apply"
+    fail=$((fail + 1))
+fi
+cp "$SAVED_C" Compiler.mod
+
 if rebuild_compiler; then
     if python3 tests/run_com_exec.py >/dev/null 2>&1; then
         echo "  ok: every executed fixture passes on the restored sources"