C frontend rewrite

Makefile

@@ -1,6 +1,6 @@
 
 dev: install-production
-	lm tests/regress/if-let.lsts
+	lm tests/regress/type-alias.lsts
 	cc -O3 tmp.c
 	./a.out
 

PLATFORM/C/LIB/default.lm

@@ -25,6 +25,7 @@ import PLATFORM/C/LIB/i32.lsts;
 import PLATFORM/C/LIB/u64.lsts;
 import PLATFORM/C/LIB/i64.lsts;
 import PLATFORM/C/LIB/f64.lsts;
+import PLATFORM/C/LIB/usize.lsts;
 import PLATFORM/C/LIB/buffer.lm;
 import PLATFORM/C/LIB/string.lm;
 import PLATFORM/C/LIB/string.lsts;

PLATFORM/C/LIB/usize.lsts

@@ -0,0 +1,3 @@
+
+type USize is U64;
+atom suffix USize = _sz;

PLUGINS/FRONTEND/C/c-parse.lsts

@@ -0,0 +1,7 @@
+
+# Loosely based on this EBNF for ANSI C
+# https://gist.github.com/Chubek/52884d1fa766fa16ae8d8f226ba105ad
+#
+# The naming of production rules try to follow this format.
+# However, there are also a large number of compiler-specific extensions that are parsed but mostly ignored
+# Example: __extension__ ( f, g )

PLUGINS/FRONTEND/LSTS/lsts-parse.lsts

@@ -88,6 +88,20 @@ let lsts-parse(tokens: List<Token>): Nil = (
                })
             }) };
          );
+         [ Token{key:c"atom"}.. Token{key:c"suffix"}.. rest] => (
+            tokens = rest;
+            let base-rest = lsts-parse-type(tokens); tokens = base-rest.second;
+            lsts-parse-expect(c"=", tokens); tokens = tail(tokens);
+            if not(non-zero(tokens)) || not(lsts-is-ident-head(lsts-parse-head(tokens))) { 
+               lsts-parse-expect(c"[Suffix]", tokens);
+            };
+            let suffix = head(tokens).key; tokens = tail(tokens);
+            lsts-parse-expect(c";", tokens); tokens = tail(tokens);
+            parse-suffixes = cons(
+               Tuple{ suffix, base-rest.first && t1(c"Constant") && t1(c"Literal") },
+               parse-suffixes
+            );
+         );
          _ => (
             let term-rest = lsts-parse-small-expression(tokens);
             let term = term-rest.first;
@@ -473,20 +487,31 @@ let lsts-parse-typedef(tokens: List<Token>): List<Token> = (
    lsts-parse-expect(c"type", tokens); tokens = tail(tokens);
    let base-rest = lsts-parse-type(tokens);
    tokens = base-rest.second;
-   lsts-parse-expect(c"=", tokens); tokens = tail(tokens);
-   let case-rest = lsts-parse-typedef-case(tokens);
-   let cases = case-rest.first;
-   tokens = case-rest.second;
-   while non-zero(tokens) && lsts-parse-head(tokens)!=c";" {
-      lsts-parse-expect(c"|", tokens); let bar = head(tokens); tokens = tail(tokens);
-      case-rest = lsts-parse-typedef-case(tokens);
-      tokens = case-rest.second;
-      cases = App{ close(App{ close(cases), close(Var{ bar.key, bar }) }), close(case-rest.first) };
-   };
-   lsts-parse-expect(c";", tokens); tokens = tail(tokens);
-   ast-parsed-program = Seq {
-      close(ast-parsed-program),
-      close(Typedef{ close(AType{ base-rest.first }), close(cases) })
+   match tokens {
+      [Token{key:c"is"}.. rest] => (
+         lsts-parse-expect(c"is", tokens); tokens = tail(tokens);
+         let rt-rest = lsts-parse-type(tokens);
+         tokens = rt-rest.second;
+         lsts-parse-expect(c";", tokens); tokens = tail(tokens);
+         add-type-alias(base-rest.first, rt-rest.first);
+      );
+      _ => (
+         lsts-parse-expect(c"=", tokens); tokens = tail(tokens);
+         let case-rest = lsts-parse-typedef-case(tokens);
+         let cases = case-rest.first;
+         tokens = case-rest.second;
+         while non-zero(tokens) && lsts-parse-head(tokens)!=c";" {
+            lsts-parse-expect(c"|", tokens); let bar = head(tokens); tokens = tail(tokens);
+            case-rest = lsts-parse-typedef-case(tokens);
+            tokens = case-rest.second;
+            cases = App{ close(App{ close(cases), close(Var{ bar.key, bar }) }), close(case-rest.first) };
+         };
+         lsts-parse-expect(c";", tokens); tokens = tail(tokens);
+         ast-parsed-program = Seq {
+            close(ast-parsed-program),
+            close(Typedef{ close(AType{ base-rest.first }), close(cases) })
+         };
+      );
    };
    tokens
 );

SRC/denormalize.lm

@@ -1,5 +1,6 @@
 
 denormalize := λ(: tt Type). (: (
+   (set tt (.rewrite-type-alias tt))
    (set tt (with-size tt))
    (set tt (with-tag tt))
    (set tt (enrich-quick-prop tt))

SRC/normalize.lm

@@ -1,6 +1,7 @@
 
 normalize := λ(: tt Type). (: (
    (let rt tt)
+   (set rt (.rewrite-type-alias rt))
    (set rt (.without-tag rt))
    # Sized can serve as a datatype if nothing else is available
    (set rt (without-size-unless-class rt))

SRC/type-alias-index.lsts

@@ -0,0 +1,26 @@
+
+let type-alias-index = {} :: HashtableEq<Tuple<CString,U64>,Tuple<Type,Type>>;
+
+let add-type-alias(lt: Type, rt: Type): Nil = (
+   type-alias-index = type-alias-index.bind( lt.ground-tag-and-arity, Tuple{ lt, rt } );
+);
+let .rewrite-type-alias(lt: Type): Type = (
+   match lt {
+      TGround{} => (
+         let lt-rt = type-alias-index.lookup( lt.ground-tag-and-arity, Tuple{ TAny, TAny } );
+         if non-zero(lt-rt.first) {
+            let tctx = unify(lt-rt.first, lt);
+            if non-zero(tctx) { lt = substitute(tctx, lt-rt.second); };
+         };
+         lt
+      );
+      TAnd{ left=left, right=right } => (
+         let new-left = left.rewrite-type-alias;
+         let new-right = right.rewrite-type-alias;
+         if not(is(left, new-left)) || not(is(right, new-right)) {
+            new-left && new-right
+         } else lt;
+      );
+      _ => lt;
+   }
+);

SRC/typeof-lhs.lm

@@ -4,10 +4,10 @@ typeof-lhs := λ(: lhs AST). (: (
    (match lhs (
       ()
       ( (App( (Lit( ':_s _ )) (App( _ (AType tt) )) )) (
-         (set r tt)
+         (set r (.rewrite-type-alias tt))
       ))
       ( (App( ps (App( (Lit( ':_s _ )) (App( _ (AType tt) )) )) )) (
-         (set r (t3( 'Cons_s (typeof-lhs ps) tt )))
+         (set r (t3( 'Cons_s (typeof-lhs ps) (.rewrite-type-alias tt) )))
       ))
       ( ASTNil (
          (set r (t1 'Nil_s))

SRC/unit-globals.lsts

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

tests/regress/type-alias.lsts

@@ -0,0 +1,15 @@
+
+#type USize is U64;
+#type U32 => U64;
+import LIB/default.lm;
+
+let f(x: U64): U64 = x + x;
+let g(x: USize): U64 = x + x + 1;
+
+print(f(1));     # normal
+print(f(1_sz));  # alias
+#print(f(1_u32)); # inference
+
+print(g(1));     # normal
+print(g(1_sz));  # alias
+#print(g(1_u32)); # inference

tests/regress/type-alias.lsts.out

@@ -0,0 +1 @@
+2233