Merge pull request #1550 from andrew-johnson-4/type2-codegen-constructors

Type2 codegen constructors

Author: andrew-johnson-4

BOOTSTRAP/cli.c

@@ -21,3 +21,15 @@ declare-binop( $"primitive::field-set", raw-type(base-type), raw-type(field-type
 
 declare-unop( $"primitive::field-get-indirect", raw-type(base-type[]), raw-type(field-type), ( l"("; x; l"->"; mangle(field-name :: L); l")"; ) );
 declare-binop( $"primitive::field-set-indirect", raw-type(base-type[]), raw-type(field-type), raw-type(Nil), ( l"("; x; l"->"; mangle(field-name :: L); l"="; y; l")"; ) );
+
+declare-unop( $"primitive::constructor", raw-type(arg-types), raw-type(return-type), (
+   l"{"; mangle-pre(return-type); l" "; uuid(return); mangle-post(return-type); l";";
+      if case-tag :: L {
+         uuid(return); l".discriminator_case_tag="; discriminator-case-tag :: L; l";";
+      };
+      for Tuple{field-name=first, field-type=second} in arguments {
+         uuid(return); l"."; mangle(field-name); l"="; $(field-name); l";"
+      };
+      uuid(return); l";";
+   l"}";
+));

PLATFORM/C/LIB/primitives.lsts

@@ -21,6 +21,14 @@ let print(io: IO::File, l: Tuple<x,y,z>): Nil = (
 );
 type Tuple<x,y,z> implements DefaultPrintable;
 
+let cmp(l: Tuple<x,y,z>, r: Tuple<x,y,z>): Ord = (
+   cmp(l.first, r.first) && cmp(l.second, r.second) && cmp(l.third, r.third)
+);
+
+let deep-hash(l: Tuple<x,y,z>): U64 = (
+   deep-hash(l.first) + deep-hash(l.second) + deep-hash(l.third)
+);
+
 let $"=="(l: Tuple<x,y>, r: Tuple<x,y>): U64 = (
    l.first == r.first && l.second == r.second
 );

PLATFORM/C/LIB/tuple.lsts

@@ -81,6 +81,8 @@ let lsts-tokenize-string(file-path: String, text: String): List<Token> = (
          tokens = cons(text[:id.length], tokens); text = rest;
       );
 
+      "$".. rest => (tokens = cons(text[:"$".length], tokens); text = rest;);
+
       (id=r/^[a-zA-Z0-9_-]+/).. rest => (
          tokens = cons(text[:id.length], tokens); text = rest;
       );

PLUGINS/FRONTEND/LSTS/lsts-smart-tokenize.lsts

@@ -53,4 +53,36 @@ let infer-type2-definition(term: AST): Nil = (
          visit-field-template(field-name, guard, field-type, term);
       };
    };
+   let common-fields = [] :: List<(CString,Type)>;
+   let has-tag-case = false;
+   for vector Tuple{ case-tag=first, case-fields=second } in cases {
+      if case-tag==c"" {
+         for vector Tuple{ field-name=first, field-type=second } in case-fields {
+            common-fields = cons((field-name, field-type), common-fields);
+         };
+      } else has-tag-case = true;
+   };
+   if not(has-tag-case) then infer-type2-yield-constructor(lhs-type, lhs-type.simple-tag, 0, common-fields);
+   let case-index = 0_u64;
+   for vector Tuple{ case-tag=first, case-fields=second } in cases {
+      if case-tag!=c"" {
+         let o-case-fields = common-fields;
+         for vector Tuple{ field-name=first, field-type=second } in case-fields {
+            o-case-fields = cons((field-name, field-type), o-case-fields);
+         };
+         infer-type2-yield-constructor(lhs-type, case-tag, case-index, o-case-fields);
+         case-index = case-index + 1;
+      };
+   };
+);
+
+let type-constructor-tag-ordinal-index = {} :: HashtableEq<(CString,U64,CString),U64>;
+
+let infer-type2-yield-constructor(base-type: Type, case-tag: CString, case-number: U64, case-fields: List<(CString,Type)>): Nil = (
+   print("Yield constructor \{case-tag}#\{case-number} : \{base-type}\n");
+   for Tuple{field-name=first, field-type=second} in case-fields {
+      print("\t\{field-name} : \{field-type}\n");
+   };
+   (let base-tag, let base-arity) = base-type.ground-tag-and-arity;
+   type-constructor-tag-ordinal-index = type-constructor-tag-ordinal-index.bind( (base-tag,base-arity,case-tag), case-number );
 );

SRC/infer-type2-definition.lsts

@@ -16,7 +16,7 @@ type2 F<c,d> implements E;
 
 type2 TT<a,b> = { a: a, b: b };
 type2 G = { a: A, b: B, h: H };
-type2 H = { g: TT<A,A> };
+type2 H = { g: TT<A,A> } H1 { g2: A } | H2 { g3: B };
 
 # TODO constructor / instantiate
 # TODO field get/set/get indirect/set indirect