TP3: set expressions with a leading constructor

CORPUS-TEST.md

@@ -78,18 +78,18 @@ 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 **57 OK / 14 errors** with the
+The remaining 71 Pascal files compile as **58 OK / 13 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.  The remaining 14 are TP3-feature gaps, not unit/Delphi noise:
+enum subranges, and a leading set constructor in a set expression.  The remaining 13 are TP3-feature gaps, not unit/Delphi noise:
 
 `BINOUT`, `CONVERT`, `DYNREC`, `FINDCHRS`, `LIST3`, `OT3`, `READARRY`,
-`READDATA`, `READINTS`, `READSTOR`, `SETS`, `STRARRAY`, `TIMEDATE`, `VARREC`.
+`READDATA`, `READINTS`, `READSTOR`, `STRARRAY`, `TIMEDATE`, `VARREC`.
 
 They reduce to four groups: `Round`/`Trunc` REAL-to-integer conversion
 (`CONVERT`), pointer-array dereference and variant/`absolute` records
-(`DYNREC`, `LIST3`, `OT3`, `VARREC`), set operations with a literal on the
-left (`FINDCHRS`, `SETS`), and text-file `Read`/`Readln` plus character-array
+(`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`).

shell/Compiler.mod

@@ -5326,7 +5326,7 @@ END RealUnary ;
 PROCEDURE Assignment (r : ERes) ;
 (* ':=' already consumed by the caller; store expression into r *)
 VAR src : ERes ;
-    k, n : CARDINAL ;
+    k, n, savePos : CARDINAL ;
     sbuf : ARRAY [0..31] OF CHAR ;
     rbuf : ARRAY [0..5] OF CHAR ;
 BEGIN
@@ -5497,57 +5497,68 @@ BEGIN
          RETURN
       END ;
       Skip () ;
-      IF CurCh () # '[' THEN
-         (* `set := set' or a set expression.  The destination is a variable
-            or a DI-addressed field; save the DI address BEFORE the right-hand
-            expression can reuse DI, then copy the runtime's bytes. *)
-         IF r.kind = 5 THEN
-            EmPushDi ()
-         END ;
-         ParseExpr (src) ;
-         IF NOT OK () THEN
+      IF CurCh () = '[' THEN
+         (* A leading constructor normally belongs to the TARGET, because its
+            type (e.g. CALC's one-byte `set of Attributes') is narrower than
+            the default 32-byte literal.  But `[A..D] - X' is an expression:
+            parse it through ParseExpr instead of storing it directly.  The
+            source cursor is reversible, so try the constructor first. *)
+         savePos := srcPos ;
+         IF NOT RdSetLiteral (r.setbase, r.setsize, sbuf) THEN
             RETURN
          END ;
-         IF src.cls # TSet THEN
-            Err (ETypeErr) ;
-            RETURN
-         END ;
-         IF r.kind = 1 THEN
-            EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
-         ELSIF r.kind # 5 THEN
-            Err (ENoLib) ;
+         Skip () ;
+         IF (CurCh () = '+') OR (CurCh () = '-') OR (CurCh () = '*') THEN
+            srcPos := savePos
+         ELSE
+            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])) ;
+                  StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ;
+                  INC (k)
+               END
+            ELSE
+               Err (ENoLib)
+            END ;
             RETURN
-         END ;
-         EmPushSetAddr (src) ;
-         n := r.setsize ;
-         IF (src.kind = 8) AND (src.setsize < n) THEN
-            n := src.setsize
-         END ;
-         EmMovAxi (n) ;
-         EmPushAx () ;
-         DropC (EmCall (TU_SetCopy)) ;
-         EmAddSp (4) ;
+         END
+      END ;
+      (* `set := set' or a set expression.  The destination is a variable
+         or a DI-addressed field; save the DI address BEFORE the right-hand
+         expression can reuse DI, then copy the runtime's bytes. *)
+      IF r.kind = 5 THEN
+         EmPushDi ()
+      END ;
+      ParseExpr (src) ;
+      IF NOT OK () THEN
          RETURN
       END ;
-      IF NOT RdSetLiteral (r.setbase, r.setsize, sbuf) THEN
+      IF src.cls # TSet THEN
+         Err (ETypeErr) ;
          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])) ;
-            StoreSymVar (r.idx, (symtab [r.idx].off + r.boff + k) MOD 10000H, 1) ;
-            INC (k)
-         END
-      ELSE
-         Err (ENoLib)
+      IF r.kind = 1 THEN
+         EmPushSymAddr (r.idx, (symtab [r.idx].off + r.boff) MOD 10000H)
+      ELSIF r.kind # 5 THEN
+         Err (ENoLib) ;
+         RETURN
+      END ;
+      EmPushSetAddr (src) ;
+      n := r.setsize ;
+      IF (src.kind = 8) AND (src.setsize < n) THEN
+         n := src.setsize
       END ;
+      EmMovAxi (n) ;
+      EmPushAx () ;
+      DropC (EmCall (TU_SetCopy)) ;
+      EmAddSp (4) ;
       RETURN
    END ;
    IF (r.kind = 5) AND (r.cls = TString) THEN

shell/tests/fixtures/expected.tsv

@@ -764,3 +764,5 @@ t126_recordassign	OK	111	21
 t127_enumsub	OK	55	6
 
 t128_intreal	OK	147	27
+
+t129_setdiff	OK	169	7

shell/tests/fixtures/t129_setdiff.out

@@ -0,0 +1 @@
+none

shell/tests/fixtures/t129_setdiff.pas

@@ -0,0 +1,9 @@
+program setdiff;
+type G = (A, B, C, D);
+     S = set of G;
+var X : S;
+begin
+  X := [A..B];
+  X := [A..B] - X;
+  if A in X then writeln('A') else writeln('none')
+end.