Lm to lsts fwjeiow

Cargo.toml

@@ -1,6 +1,6 @@
 [package]
 name = "lambda_mountain"
-version = "1.20.34"
+version = "1.20.35"
 authors = ["Andrew <[email protected]>"]
 license = "MIT"
 description = "Typed Macro Assembler (backed by Coq proofs-of-correctness)"

PLUGINS/FRONTEND/LM/parse-toplevel.lm

@@ -58,7 +58,7 @@ parse-toplevel := λ(: tokens List<Token>). (: (
                         )))
                      )))
                      (let base-type (type-of-s e1))
-                     (add-class-info( base-type (ClassInfo( FragmentStyle )) ))
+                     (add-class-info-layout( base-type FragmentStyle ))
                      (set tokens r2)
                   ))
                )))

SRC/class-info-index.lsts

@@ -1,19 +1,57 @@
 
-type StructLayout = LM1Style | CStyle | FragmentStyle;
+type StructLayout = LM1Style | CStyle | FragmentStyle | UnknownStyle;
 
 type ClassInfo = ClassInfo { layout: StructLayout };
 let class-info-index = {} :: HashtableEq<Tuple<CString,U64>,ClassInfo>;
 
-let add-class-info(cls: Type, info: ClassInfo): Nil = (
-   class-info-index = class-info-index.bind( cls.ground-tag-and-arity, info );
+let class-info-default = ClassInfo{ UnknownStyle };
+let .with-layout(ci: ClassInfo, layout: StructLayout): ClassInfo = (
+   ClassInfo{ layout }
+);
+
+let add-class-info-layout(cls: Type, layout: StructLayout): Nil = (
+   class-info-index = class-info-index.bind(
+      cls.ground-tag-and-arity,
+      class-info-index.lookup(cls.ground-tag-and-arity,class-info-default).with-layout(layout)
+   );
 );
 
 let .is-class(cls: Type): U64 = class-info-index.has(cls.ground-tag-and-arity);
 let .is-lm-struct(cls: Type): U64 = (
    let ta = cls.ground-tag-and-arity;
-   is(class-info-index.lookup(ta, ClassInfo{ FragmentStyle }).layout, LM1Style)
+   is(class-info-index.lookup(ta, class-info-default).layout, LM1Style)
 );
 let .is-fragment(cls: Type): U64 = (
    let ta = cls.ground-tag-and-arity;
-   is(class-info-index.lookup(ta, ClassInfo{ LM1Style }).layout, FragmentStyle)
+   is(class-info-index.lookup(ta, class-info-default).layout, FragmentStyle)
+);
+
+let index-fields-of-tag(tag: CString, base-type: Type, fields-params: Type, fields-rhs: Type): Nil = (
+   index-fields-quick-prop( t1(c"Tag::" + tag), base-type, fields-rhs, 1 );
+   index-fields-quick-prop( t1(c"Tag::" + tag), t3( c"Array", base-type, TAny), fields-rhs, 1 );
+);
+
+let index-fields-quick-prop(tag-tt: Type, base-type: Type, fields-tt: Type, field-index: U64): Nil = (
+   match fields-tt {
+      TGround{ tag:c"Cons", parameters:[pt.. rst..] } => (
+         add-quick-prop( tag-tt, base-type,
+            t2( c"Field::" + to-string(field-index), pt )
+         );
+         if is-only-child(base-type) {
+            add-quick-prop( t3( c"Array", base-type, TAny ), t3( c"Array", base-type, TAny ),
+               t2( c"Field::" + to-string(field-index), pt )
+            )
+         };
+         index-fields-quick-prop( tag-tt, base-type, rst, field-index + 1)
+      );
+      TGround{ tag:c"Nil" } => ();
+      pt => (
+         add-quick-prop( tag-tt, base-type,
+            t2( c"Field::" + to-string(field-index), pt )
+         );
+         add-quick-prop( t3( c"Array", base-type, TAny ), t3( c"Array", base-type, TAny ),
+            t2( c"Field::" + to-string(field-index), pt )
+         )
+      );
+   }
 );

SRC/class-of-tag.lm

@@ -3,7 +3,7 @@ tag-to-class-index := (: (HashtableEq( 0_u64 0_u64 (as 0_u64 Tuple<String,Type>[
 
 index-class-of-tag := λ(: tag String)(: class Type). (: (
    (set tag-to-class-index (.bind( tag-to-class-index tag class )))
-   (add-class-info( class (ClassInfo( LM1Style )) ))
+   (add-class-info-layout( class LM1Style ))
 ) Nil);
 
 class-of-tag := λ(: tag String). (: (

SRC/index-concrete-type-instances.lm

@@ -2,14 +2,6 @@
 concrete-type-instances-index := (: (HashtableEq( 0_u64 0_u64 (as 0_u64 Tuple<Tuple<String,U64>,List<Type>>[]) )) HashtableEq<Tuple<String,U64>,List<Type>>);
 
 add-concrete-type-instance := λ(: tt Type). (: (
-   (match (fields-of-tag(tag-of tt)) (
-      ()
-      ( (Tuple( lhst rhst )) (if (non-zero lhst) (
-         (let tctx (unify( lhst tt )))
-         (set rhst (substitute( tctx rhst )))
-         (add-concrete-type-instance rhst)
-      ) ()))
-   ))
    (set tt (normalize tt))
    (let lt (.slot( tt 'Array_s )))
    (if (non-zero lt) (set tt lt) (set tt (.with-only-class tt)))

SRC/index-types.lm

@@ -7,7 +7,6 @@ import SRC/quick-prop.lsts;
 import SRC/substitute.lm;
 import SRC/cons-root.lsts;
 import SRC/index-concrete-type-instances.lm;
-import SRC/type-index.lm;
 import SRC/infer-expr.lm;
 import SRC/phi-transition.lsts;
 import SRC/phi-merge.lsts;
@@ -23,7 +22,6 @@ import SRC/size-of-class.lm;
 import SRC/class-of-tag.lm;
 import SRC/is-only-child.lsts;
 import SRC/is-sized-array.lsts;
-import SRC/fields-of-tag.lm;
 import SRC/type-complex-fields.lm;
 import SRC/get-vararg-inner.lm;
 import SRC/maybe-specialize.lm;

SRC/type-index.lsts

@@ -0,0 +1,5 @@
+
+let type-index = HashtableIs{ 0, 0, 0 as Tuple<AST,Type>[] };
+
+let typeof(t: AST): Type = type-index.lookup(t,TAny);
+let ascript(t: AST, tt: Type): Nil = type-index = type-index.bind(t, tt);

SRC/unit-globals.lsts

@@ -5,6 +5,7 @@ import SRC/tctx-bind.lsts;
 
 # global indexes
 import SRC/class-info-index.lsts;
+import SRC/type-index.lsts;
 
 # queries dependent on index information
 import SRC/with-only-class.lsts;