Przeglądaj źródła

String, variant-record assignment, nested modules, ADDRESS<->pointer

- Opaque/forward (undeclared) aliases are pointer-like: ClassOf returns
  ClPtr, so Design/DeclVar/ResClass/AssOrCall treat them as pointers;
  gm2's pervasive String is predefined (imported definitions shadow it).
  Fixes filesystem.mod / opaque2.mod and NIL/copy/compare on String.
- Variant-record assignment: CopyRecord is now a flat byte blit of
  TypeSize(t) (correct for overlapping variant fields; records are flat
  blobs); variant records are emitted as one zeroed blob.  Previously
  it compiled but corrupted data / segfaulted.
- ADDRESS <-> pointer assignment: move the ADDRESS checks before the
  pointer-subclass test in SymTab.Assignable (p := ADR(x) now works).
- Nested local MODULE: verified exported names, procedures, nested-
  nested modules and init bodies lower correctly (docs updated).
- Tests t_variant2/t_string/t_addrptr/t_nestedmod; suite 169/169;
  fixpoint OK (2,730,510 bytes).  gm2 testsuite corpus 376 -> 395
  compile-OK (0 CRASH); gm2 stdlib 124 -> 131.
Eric Streit 1 tydzień temu
rodzic
commit
6882d63998

+ 4 - 0
compiler/run_tests.sh

@@ -74,6 +74,10 @@ expect_run t_minmax2.mod 42
 expect_run t_setops.mod 42
 expect_run t_setops.mod 42
 expect_run t_fwdtype.mod 42
 expect_run t_fwdtype.mod 42
 expect_run t_libc.mod 42
 expect_run t_libc.mod 42
+expect_run t_variant2.mod 42
+expect_run t_string.mod 42
+expect_run t_addrptr.mod 42
+expect_run t_nestedmod.mod 42
 expect_run t_nestidx.mod 42
 expect_run t_nestidx.mod 42
 expect_run t_proctype.mod 42
 expect_run t_proctype.mod 42
 expect_run t_compat.mod 42
 expect_run t_compat.mod 42

+ 17 - 31
compiler/src/QbeGen.mod

@@ -2025,9 +2025,16 @@ PROCEDURE EmitVTables;
 
 
 PROCEDURE DeclRec (name: ARRAY OF CHAR; t: INTEGER);
 PROCEDURE DeclRec (name: ARRAY OF CHAR; t: INTEGER);
   VAR first: BOOLEAN;
   VAR first: BOOLEAN;
-    vt: QVal;
+    vt, sz: QVal;
   BEGIN
   BEGIN
     IF NOT opened THEN RETURN END;
     IF NOT opened THEN RETURN END;
+    IF SymTab.IsVariant(t) AND (SymTab.ClassOf(t) = SymTab.ClRecord) THEN
+      (* variant record: fields overlay, so emit one zero-filled blob
+         of the record's (max) size *)
+      IntStr(VAL(INTEGER, SymTab.TypeSize(t)), sz);
+      W("data $"); W(name); W(" = { z "); W(sz); WL(" }");
+      RETURN
+    END;
     RecStatics(name, t);
     RecStatics(name, t);
     W("data $"); W(name);
     W("data $"); W(name);
     W(" = { ");
     W(" = { ");
@@ -2078,37 +2085,16 @@ PROCEDURE TopWith (VAR base: QVal): BOOLEAN;
 
 
 PROCEDURE CopyRecord (dst: ARRAY OF CHAR; src: ARRAY OF CHAR;
 PROCEDURE CopyRecord (dst: ARRAY OF CHAR; src: ARRAY OF CHAR;
                        t: INTEGER);
                        t: INTEGER);
-(* Deep whole-record copy: scalars/sets by load/store, arrays via
-   CopyArray on dereferenced fields, nested records recurse. *)
-  VAR n, i: CARDINAL;
-    fn: SymTab.Name;
-    ft: SymTab.TypeIndex;
-    cls: INTEGER;
-    dd, ds, di, si, v: QVal;
-    off: QVal;
+(* Whole-record copy: a flat byte blit of the record's (max) size.
+   Records are flat blobs (scalars/sets/pointers inline, arrays and
+   nested records inline), so this is correct — and the only correct
+   choice for variant records, whose fields overlay. *)
+  VAR n: QVal;
   BEGIN
   BEGIN
-    n := SymTab.FieldCount(t);
-    i := 0;
-    WHILE i < n DO
-      SymTab.FieldName(t, i, fn);
-      ft := SymTab.FieldType(t, fn);
-      cls := SymTab.ClassOf(ft);
-      IntStr(SymTab.FieldOffset(t, fn), off);
-      NewTemp(dd); Op3L("add", dd, dst, off);
-      NewTemp(ds); Op3L("add", ds, src, off);
-      IF cls = SymTab.ClArray THEN
-        (* inline array field: the field address is the descriptor *)
-        CopyArray(dd, ds, ft)
-      ELSIF cls = SymTab.ClSet THEN
-        CopySet(dd, ds, SymTab.SetWords(ft), SymTab.SetWords(ft))
-      ELSIF (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) THEN
-        CopyRecord(dd, ds, ft)
-      ELSE
-        ElemLoad(ds, ft, v);
-        ElemStore(dd, v, ft)
-      END;
-      INC(i)
-    END
+    IntStr(VAL(INTEGER, SymTab.TypeSize(t)), n);
+    Revive;
+    W("  call $memcpy(l "); W(dst); W(", l "); W(src);
+    W(", l "); W(n); WL(")")
   END CopyRecord;
   END CopyRecord;
 
 
 PROCEDURE WordsBytes (words: CARDINAL): CARDINAL;
 PROCEDURE WordsBytes (words: CARDINAL): CARDINAL;

+ 16 - 6
compiler/src/SymTab.mod

@@ -837,7 +837,14 @@ PROCEDURE ClassOf (t: TypeIndex): INTEGER;
   VAR r: TypeIndex;
   VAR r: TypeIndex;
   BEGIN
   BEGIN
     r := Resolve(t);
     r := Resolve(t);
-    IF r = InvalidType THEN RETURN ClInvalid END;
+    IF r = InvalidType THEN
+      (* an opaque/undeclared alias (e.g. gm2's String) is pointer-like *)
+      IF (t >= 0) AND (t < VAL(INTEGER, nTypes))
+         AND (tform[t] = FAlias) THEN
+        RETURN ClPtr
+      END;
+      RETURN ClInvalid
+    END;
     CASE tform[r] OF
     CASE tform[r] OF
       FInt : RETURN ClInt
       FInt : RETURN ClInt
     | FLong : RETURN ClLong
     | FLong : RETURN ClLong
@@ -2669,17 +2676,18 @@ PROCEDURE Assignable (src, dst: TypeIndex): BOOLEAN;
     IF ClassOf(src) = ClNil THEN
     IF ClassOf(src) = ClNil THEN
       RETURN ClassOf(dst) = ClPtr
       RETURN ClassOf(dst) = ClPtr
     END;
     END;
-    (* POINTER TO Derived assigns to POINTER TO Base (subtyping) *)
-    IF (ClassOf(src) = ClPtr) AND (ClassOf(dst) = ClPtr) THEN
-      RETURN IsSubclass(PtrBase(src), PtrBase(dst))
-    END;
-    (* ADDRESS assigns to/from any pointer *)
+    (* ADDRESS assigns to/from any pointer (check before the subclass
+       test, which returns early) *)
     IF (Resolve(src) = dAddr) AND (ClassOf(dst) = ClPtr) THEN
     IF (Resolve(src) = dAddr) AND (ClassOf(dst) = ClPtr) THEN
       RETURN TRUE
       RETURN TRUE
     END;
     END;
     IF (Resolve(dst) = dAddr) AND (ClassOf(src) = ClPtr) THEN
     IF (Resolve(dst) = dAddr) AND (ClassOf(src) = ClPtr) THEN
       RETURN TRUE
       RETURN TRUE
     END;
     END;
+    (* POINTER TO Derived assigns to POINTER TO Base (subtyping) *)
+    IF (ClassOf(src) = ClPtr) AND (ClassOf(dst) = ClPtr) THEN
+      RETURN IsSubclass(PtrBase(src), PtrBase(dst))
+    END;
     IF (ClassOf(src) = ClInt) AND (ClassOf(dst) = ClInt) THEN
     IF (ClassOf(src) = ClInt) AND (ClassOf(dst) = ClInt) THEN
       RETURN TRUE
       RETURN TRUE
     END;
     END;
@@ -2958,6 +2966,8 @@ PROCEDURE Init;
     Predef("CARDINAL16", KindPredef, dCard);
     Predef("CARDINAL16", KindPredef, dCard);
     Predef("CARDINAL32", KindPredef, dCard);
     Predef("CARDINAL32", KindPredef, dCard);
     Predef("CARDINAL64", KindPredef, dLong);
     Predef("CARDINAL64", KindPredef, dLong);
+    (* gm2's pervasive opaque dynamic-string type (pointer-sized). *)
+    Predef("String", KindPredef, dAddr);
     Predef("NIL", KindConst, dNil)
     Predef("NIL", KindConst, dNil)
   END Init;
   END Init;
 
 

+ 12 - 0
compiler/tests/t_addrptr.mod

@@ -0,0 +1,12 @@
+MODULE taddrptr;
+// ADDRESS <-> pointer assignment.
+FROM SYSTEM IMPORT ADR;
+TYPE Arr = ARRAY [0..2] OF INTEGER;
+VAR a : Arr; p : POINTER TO Arr; q : POINTER TO INTEGER; v : INTEGER;
+VAR ExitCode : INTEGER;
+BEGIN
+  a[1] := 42;
+  p := ADR(a);
+  q := ADR(v); q^ := 7;
+  IF (p^[1] = 42) AND (v = 7) THEN ExitCode := 42 ELSE ExitCode := 1 END
+END taddrptr.

+ 13 - 0
compiler/tests/t_nestedmod.mod

@@ -0,0 +1,13 @@
+MODULE tnestedmod;
+// Local (nested) MODULE: exported procedure/var + init body.
+MODULE acc;
+  EXPORT Value, Bump;
+  VAR y : INTEGER;
+  PROCEDURE Value : INTEGER; BEGIN RETURN y END Value;
+  PROCEDURE Bump; BEGIN y := y + 6 END Bump;
+BEGIN y := 36 END acc;
+VAR ExitCode : INTEGER;
+BEGIN
+  Bump();
+  IF Value() = 42 THEN ExitCode := 42 ELSE ExitCode := 1 END
+END tnestedmod.

+ 8 - 0
compiler/tests/t_string.mod

@@ -0,0 +1,8 @@
+MODULE tstring;
+// gm2's pervasive opaque String type (pointer-like).
+VAR s, t : String;
+VAR ExitCode : INTEGER;
+BEGIN
+  s := NIL; t := s;
+  IF (s = NIL) AND (t = NIL) THEN ExitCode := 42 ELSE ExitCode := 1 END
+END tstring.

+ 15 - 0
compiler/tests/t_variant2.mod

@@ -0,0 +1,15 @@
+MODULE tvarassign;
+// Whole-variant-record assignment (flat blit; overlapping fields).
+TYPE R = RECORD k: INTEGER;
+                CASE tag: BOOLEAN OF
+                  TRUE : b: INTEGER |
+                  FALSE: c: ARRAY [0..7] OF CHAR
+                END END;
+VAR r, q : R;
+VAR ExitCode : INTEGER;
+BEGIN
+  r.k := 1; r.tag := TRUE; r.b := 99;
+  q := r;
+  IF (q.k = 1) AND (q.tag = TRUE) AND (q.b = 99) THEN ExitCode := 42
+  ELSE ExitCode := 1 END
+END tvarassign.

+ 10 - 7
docs/analysis_gaps.md

@@ -1,12 +1,12 @@
 # m2compiler-V3 — gap analysis (2026-09-30)
 # m2compiler-V3 — gap analysis (2026-09-30)
 
 
-Suite **165/165**, self-hosting fixpoint OK (2,745,278 bytes).
+Suite **169/169**, self-hosting fixpoint OK (2,730,510 bytes).
 Corpus at this point (with `$V3_LIBS`):
 Corpus at this point (with `$V3_LIBS`):
 
 
 | corpus | compile-OK | CRASH | LANG |
 | corpus | compile-OK | CRASH | LANG |
 | --- | --- | --- | --- |
 | --- | --- | --- | --- |
-| gm2 testsuite (612) | 376 | 0 | 227 |
-| gm2 stdlib (336) | 124 | 0 | 212 |
+| gm2 testsuite (612) | 395 | 0 | 209 |
+| gm2 stdlib (336) | 131 | 0 | 205 |
 
 
 Failure taxonomy (testsuite, per file): `undeclared identifier` 65,
 Failure taxonomy (testsuite, per file): `undeclared identifier` 65,
 `not supported yet` 43, `invalid call` 25, `incompatible assignment`
 `not supported yet` 43, `invalid call` 25, `incompatible assignment`
@@ -101,7 +101,10 @@ hex, `NOT`/`AND`/`OR` only, TopSpeed legacy isolated in the sidecar.
 5. ~~**Forward type references**~~ ✅ (module-level globals; TYPE-block
 5. ~~**Forward type references**~~ ✅ (module-level globals; TYPE-block
    forwards already worked)
    forwards already worked)
 
 
-Remaining after today: `String`, `GOTO`/labels, variant-record
-assignment, nested-`MODULE` lowering, result suffixes, generics,
-coroutines, multiple inheritance (deliberate); `ADDRESS`↔pointer
-assignment; and the library holes in §2.
+Also done: `String` (opaque/pointer-like), variant-record
+assignment (flat blit), nested-`MODULE` lowering, `ADDRESS`↔pointer
+assignment.
+
+Remaining after today: `GOTO`/labels, result suffixes, generics,
+coroutines, multiple inheritance (deliberate), and the library holes
+in §2.

+ 13 - 6
docs/features.md

@@ -1,4 +1,4 @@
-# m2compiler-V3 — feature status (at `v3-gaps-1-5`, 165/165 green)
+# m2compiler-V3 — feature status (at `v3-string-variant-nested`, 169/169 green)
 
 
 Pipeline: Coco/R `M2.atg` (1748 lines, 73 productions) → `gm2`-built
 Pipeline: Coco/R `M2.atg` (1748 lines, 73 productions) → `gm2`-built
 `M2` → QBE `.ssa` → `qbe` → `cc` → run. `SymTab.mod` 1623 lines,
 `M2` → QBE `.ssa` → `qbe` → `cc` → run. `SymTab.mod` 1623 lines,
@@ -49,22 +49,29 @@ Legend: ✅ done · 🔄 partial · ⏸ not started / deferred.
   including variant records (`RECORD … ; CASE tag : T OF … END`): plain
   including variant records (`RECORD … ; CASE tag : T OF … END`): plain
   fields pack before the tag, each branch's fields overlay after it.
   fields pack before the tag, each branch's fields overlay after it.
 - ✅ `SET OF` bool/char/subrange (multi-word masks).
 - ✅ `SET OF` bool/char/subrange (multi-word masks).
-- ✅ `POINTER TO`, `NIL` as a real type.
+- ✅ `POINTER TO`, `NIL` as a real type, `ADDRESS` ↔ any pointer
+  assignment (`p := ADR(x)`).
 - ✅ `UCHAR` (32-bit codepoint) + `U'a'`/`U"…"` literals (strict
 - ✅ `UCHAR` (32-bit codepoint) + `U'a'`/`U"…"` literals (strict
   RFC3629 decode → 234 on bad bytes), `UCHR`/`CHR8`/`UORD`, `U"…"`
   RFC3629 decode → 234 on bad bytes), `UCHR`/`CHR8`/`UORD`, `U"…"`
   whole-string assignment to a 1-D `ARRAY OF UCHAR`, `+`
   whole-string assignment to a 1-D `ARRAY OF UCHAR`, `+`
   concatenation of `U"…"` (and single-codepoint operands), and
   concatenation of `U"…"` (and single-codepoint operands), and
   `LEN`/`LENGTH`/`HIGH` of a UString.
   `LEN`/`LENGTH`/`HIGH` of a UString.
 - ✅ Opaque `TYPE T;` + completion in the implementation.
 - ✅ Opaque `TYPE T;` + completion in the implementation.
-- ✅ Variant records (`RECORD CASE … OF … END`); ⏸ whole-record
-  equality/assignment for variants is 236 (overlapping storage).
+- ✅ Variant records (`RECORD CASE … OF … END`); whole-record
+  assignment is a flat byte blit (correct for overlapping fields) and
+  whole-record `=` is 213.
+- ✅ gm2's pervasive opaque `String`: an undeclared/opaque type is
+  pointer-like (assign `NIL`, copy, compare, pass), and `String` is
+  predefined (imported definitions shadow it).
 
 
 ## Declarations
 ## Declarations
 - ✅ `CONST` (integer/char/real literals, folded), `VAR`, `TYPE`,
 - ✅ `CONST` (integer/char/real literals, folded), `VAR`, `TYPE`,
   `PROCEDURE` headings + bodies, `FORWARD`.
   `PROCEDURE` headings + bodies, `FORWARD`.
 - ✅ `DEFINITION`/`IMPLEMENTATION` modules, `IMPORT`/`FROM … IMPORT`,
 - ✅ `DEFINITION`/`IMPLEMENTATION` modules, `IMPORT`/`FROM … IMPORT`,
-  `EXPORT` (parsed), nested local `MODULE` (parsed; lowering pending).
-- ✅ Opaque completion; module `BEGIN` init bodies.
+  `EXPORT` (parsed), nested local `MODULE` (including `EXPORT` lists,
+  nested-nested modules, and bodies lowered as startup init functions).
+- ✅ Opaque completion; opaque/forward types used as pointer-like
+  values; module `BEGIN` init bodies.
 - ✅ Strict impl-vs-def signature checks (error **235**): result type,
 - ✅ Strict impl-vs-def signature checks (error **235**): result type,
   formal count, formal types and `VAR`-ness are compared against the
   formal count, formal types and `VAR`-ness are compared against the
   `DEFINITION` (was arity-only).
   `DEFINITION` (was arity-only).

+ 17 - 5
docs/summary_v3-corpus.md

@@ -1,6 +1,6 @@
 # Step: V3 compiler corpus runs
 # Step: V3 compiler corpus runs
 
 
-Tag `v3-corpus-run`. V3 suite **165/165**, fixpoint OK.
+Tag `v3-corpus-run`. V3 suite **169/169**, fixpoint OK.
 
 
 ## Why
 ## Why
 
 
@@ -22,19 +22,19 @@ gap).
 
 
 | | no libs | with `$V3_LIBS` |
 | | no libs | with `$V3_LIBS` |
 | --- | --- | --- |
 | --- | --- | --- |
-| **compile-OK** | 242 | **376** |
+| **compile-OK** | 242 | **395** |
 | CRASH | 0 | 0 |
 | CRASH | 0 | 0 |
 | LIB | 185 | **9** |
 | LIB | 185 | **9** |
-| LANG | 185 | **227** |
+| LANG | 185 | **209** |
 
 
 **2. gm2 standard libraries** (`m2pim`/`m2iso`/`m2log`/`m2cor`/`m2min`,
 **2. gm2 standard libraries** (`m2pim`/`m2iso`/`m2log`/`m2cor`/`m2min`,
 336 files):
 336 files):
 
 
 | | no libs | with `$V3_LIBS` |
 | | no libs | with `$V3_LIBS` |
 | --- | --- | --- |
 | --- | --- | --- |
-| **compile-OK** | 78 | **124** |
+| **compile-OK** | 78 | **131** |
 | LIB | 176 | **0** |
 | LIB | 176 | **0** |
-| LANG | 82 | **212** |
+| LANG | 82 | **205** |
 
 
 (With the import path set, LIB noise is gone and the true LANG counts
 (With the import path set, LIB noise is gone and the true LANG counts
 are visible.)
 are visible.)
@@ -104,6 +104,18 @@ are visible.)
 17. **Module-level forward type references** — a global may name a type
 17. **Module-level forward type references** — a global may name a type
     declared further down; emission is deferred until the TYPE block
     declared further down; emission is deferred until the TYPE block
     completes (TYPE-block forwards already worked).
     completes (TYPE-block forwards already worked).
+18. **`String` and opaque/forward types** — an undeclared or opaque
+    alias is pointer-like (`NIL`, copy, compare, pass); gm2's pervasive
+    `String` is predefined (imported definitions shadow it).
+19. **Variant-record assignment** — whole-record assignment is now a
+    flat byte blit of the (max) record size, correct for overlapping
+    variant fields; variant records are emitted as a zeroed blob.
+    (Previously it compiled but crashed / corrupted data.)
+20. **Nested local `MODULE`** — exported names, nested-nested modules
+    and bodies are lowered as startup init functions (was already
+    largely working; verified and documented).
+21. **`ADDRESS` ↔ pointer assignment** (`p := ADR(x)`), checked before
+    the pointer-subclass test.
 
 
 ## Remaining LANG gaps
 ## Remaining LANG gaps