Merge pull request #1504 from andrew-johnson-4/start-using-new-macros

andrew-johnson-4 · web-flow · commit e13e4101fec9 · 2025-05-13T20:33:15.000-06:00
Start using new macros
diff --git a/BOOTSTRAP/cli.c b/BOOTSTRAP/cli.c
diff --git a/Makefile b/Makefile
@@ -1,5 +1,5 @@
 CC = cc
-CFLAGS = -O3 -march=native -mtune=native
+CFLAGS = -O3 -march=native -mtune=native -ferror-limit=50
 
 dev: install-production
 	lm t.lsts
diff --git a/PLATFORM/C/LIB/common-macros.lsts b/PLATFORM/C/LIB/common-macros.lsts
@@ -1,7 +1,7 @@
 
-#typed macro macro::let(lhs: lazy, rhs: lazy): lazy = (
-#   (fn(lhs) = ()) (rhs)
-#);
+typed macro macro::let(lhs: lazy, rhs: lazy): lazy = (
+   (fn(lhs) = ()) (rhs)
+);
 
 typed macro macro::for(item: lazy, iter: List<?>, loop: lazy): lazy = (
    let uuid(iter-term) = iter;
diff --git a/PLUGINS/BACKEND/C/compile-c.lm b/PLUGINS/BACKEND/C/compile-c.lm
@@ -14,7 +14,7 @@ plugins-backend-c-compile := λ . (: (
                (set global-ctx (.bind(
                   global-ctx k kt fragment
                )))
-               (set std-c-fragment-context (.bind( std-c-fragment-context g-t fragment )))
+               (set std-c-fragment-context (.bind( std-c-fragment-context (def-to-sym g-t) fragment )))
             ) (
                (let clean-tt (.without-tag kt))
                (let mid (mangle-identifier( k clean-tt )))
@@ -25,13 +25,13 @@ plugins-backend-c-compile := λ . (: (
                   (set global-ctx (.bind(
                      global-ctx k kt fragment
                   )))
-                  (set std-c-fragment-context (.bind( std-c-fragment-context g-t fragment )))
+                  (set std-c-fragment-context (.bind( std-c-fragment-context (def-to-sym g-t) fragment )))
                ) (
                   (let repr-tt (&&( clean-tt (t1 'GlobalVariable_s) )))
                   (set global-ctx (.bind(
                      global-ctx k repr-tt fragment
                   )))
-                  (set std-c-fragment-context (.bind( std-c-fragment-context g-t fragment )))
+                  (set std-c-fragment-context (.bind( std-c-fragment-context (def-to-sym g-t) fragment )))
                ))
             ))
          ))
diff --git a/PLUGINS/BACKEND/C/compile-expr-direct.lm b/PLUGINS/BACKEND/C/compile-expr-direct.lm
@@ -25,15 +25,15 @@ compile-expr-direct := λ(: ctx FContext)(: term AST)(: stack-offset I64)(: used
                   (set e (compile-expr( ctx t stack-offset Used )))
                ) )
                ( (TGround( 'Array_s (LCons( TAny (LCons( inner-tt LEOF )) )) )) (
-                  (let fterm (.lookup( var-to-def-index o-t ASTEOF )))
+                  (let fterm (var-to-def o-t))
                   (set e (std-c-compile-call( ctx 'open_s fterm t )))
                ))
                ( (TGround( 'Array_s (LCons( array-length (LCons( inner-tt LEOF )) )) )) (
                   (set e (compile-expr( ctx t stack-offset Used )))
                ))
             ))
          ) (
-            (let fterm (.lookup( var-to-def-index o-t ASTEOF )))
+            (let fterm (var-to-def o-t))
             (set e (std-c-compile-call( ctx 'open_s fterm t )))
          ))
       ))
@@ -184,7 +184,7 @@ compile-expr-direct := λ(: ctx FContext)(: term AST)(: stack-offset I64)(: used
             (match f (
                ()
                ( (Var( fname _ )) (
-                  (let fterm (.lookup( var-to-def-index f ASTEOF )))
+                  (let fterm (var-to-def f))
                   (set e (std-c-compile-call( ctx fname fterm a )))
                ))
                ( (Lit( fname _ )) (
diff --git a/PLUGINS/BACKEND/C/compile-program-ordered.lm b/PLUGINS/BACKEND/C/compile-program-ordered.lm
@@ -3,7 +3,7 @@ compile-program-ordered := λ(: global-ctx FContext)(: program AST). (: (
    (for-each-v (g in (.unroll-seq program)) (match g (
       ()
       ( (Glb( k_t rhs )) (
-         (if (.is-open(typeof g)) () (
+         (if (.is-open(typeof(def-to-sym g))) () (
             (compile-global( global-ctx k rhs ))
          ))
       ))
diff --git a/PLUGINS/BACKEND/C/std-c-compile-call.lsts b/PLUGINS/BACKEND/C/std-c-compile-call.lsts
@@ -1,5 +1,6 @@
 
 let std-c-compile-call(ctx: FContext, fname: CString, fterm: AST, args: AST): Fragment = (
+   fterm = find-global-callable(fname, typeof(args));
    if not(non-zero(fterm)) then fail("std-c-compile-call Function was null: \{fterm}\nArguments: \{typeof(args)}\n");
    if typeof(fterm).is-t(c"Blob") {
       let r = mk-fragment();
diff --git a/PLUGINS/BACKEND/C/std-c-compile-expr.lsts b/PLUGINS/BACKEND/C/std-c-compile-expr.lsts
@@ -2,7 +2,7 @@
 let std-c-compile-expr(ctx: FContext, t: AST, is-stmt: Bool): Fragment = (
    let f = match t {
       Var{ key=key } => (
-         let def = var-to-def-index.lookup(t, ASTEOF);
+         let def = var-to-def(t);
          let e = std-c-fragment-context.lookup(def, mk-fragment());
          if not(non-zero(e)) {
             exit-error( untern("Unable to Find Variable Fragment in Context: \{key}"), t );
diff --git a/PLUGINS/FRONTEND/LSTS/lsts-parse.lsts b/PLUGINS/FRONTEND/LSTS/lsts-parse.lsts
@@ -1061,16 +1061,16 @@ let lsts-parse-small-expression(tokens: List<Token>): Tuple<AST,List<Token>> = (
          lsts-parse-expect(c"=", tokens); tokens = tail(tokens);
          let rhs-rest = lsts-parse-small-expression(tokens);
          tokens = rhs-rest.second;
-         #base = mk-app(
-         #   mk-var(with-location(mk-token("macro::let"),loc)),
-         #   mk-cons(lhs-rest.first, rhs-rest.first)
-         #);
          base = mk-app(
-            mk-app(
-               mk-var(with-location(mk-token("let"),loc)),
-               lhs-rest.first
-            ), rhs-rest.first
+            mk-var(with-location(mk-token("macro::let"),loc)),
+            mk-cons(lhs-rest.first, rhs-rest.first)
          );
+         #base = mk-app(
+         #   mk-app(
+         #      mk-var(with-location(mk-token("let"),loc)),
+         #      lhs-rest.first
+         #   ), rhs-rest.first
+         #);
       );
       [Token{key:c"while"}.. rest] => (
          let loc = head(tokens).location; tokens = rest;
diff --git a/SRC/ascript-normal.lsts b/SRC/ascript-normal.lsts
@@ -9,11 +9,13 @@ let ascript-normal(t: AST, tt: Type): Nil = (
                exit-error("Type Ascription Inequality\n\{normalize(typeof(t))} does not imply \{normalize(tt)}", t);
             }
          }
-      } else {
-         add-concrete-type-instance(tt);
-         tt = denormalize(tt);
-         ascript(t, tt);
-         types-have-changed = true;
-      }
+      } else ascript-force(t, tt);
    }
 );
+
+let ascript-force(t: AST, tt: Type): Nil = (
+   add-concrete-type-instance(tt);
+   tt = denormalize(tt);
+   ascript(t, tt);
+   types-have-changed = true;
+);
diff --git a/SRC/decorate-var-to-def.lsts b/SRC/decorate-var-to-def.lsts
@@ -8,6 +8,6 @@ let mark-var-to-def-todo(tctx: Maybe<TContext>, k: CString, tt: Type, t: AST): N
 let decorate-var-to-def(): Nil = (
    for vector Tuple{tctx=first, k=second, tt=third, t=fourth} in decorate-var-to-def-todo {
       let def = defof-var(t, tctx, k, tt);
-      if non-zero(def) then var-to-def-index = var-to-def-index.bind(t, def);
+      if non-zero(def) then mark-var-to-def(t, def);
    }
 );
diff --git a/SRC/infer-global-terms.lsts b/SRC/infer-global-terms.lsts
@@ -11,7 +11,11 @@ let infer-global-terms(term: AST): AST = (
       Glb{val:Abs{}} => ();
       Glb{k=key, rhs=val} => (
          (_, let new-rhs) = std-infer-expr((None :: TContext?), rhs, false, Used, TAny);
-         if not(is(rhs,new-rhs)) then term = mk-glb(k, new-rhs);
+         if not(is(rhs,new-rhs)) then {
+            let new-term = mk-glb(k, new-rhs);
+            mark-var-to-def(new-term, term);
+            term = new-term;
+         };
          let kt = normalize(typeof(rhs)) && t1(c"GlobalVariable");
          global-type-context = global-type-context.bind(k.key, kt, term);
          mark-global-as-seen(k.key, kt, TAny);
diff --git a/SRC/preprocess-apply-hard.lm b/SRC/preprocess-apply-hard.lm
@@ -39,15 +39,6 @@ preprocess-apply-hard := λ(: macro-name String)(: arity U64)(: program AST). (:
       ( _ (set macros MEOF) )
    )))
    (if (not matched) (
-      (let macro-list preprocess-macros)
-      (while (non-zero macro-list) (match macro-list (
-         ()
-         ( (MSeq( rst (Macro( ml mr )) )) (
-            (print 'Macro\s_s)(print ml)(print '\s=>\s_s)(print mr)(print '\n_s)
-            (set macro-list rst)
-         ))
-      )))
-      (print 'Args\s_s)(print program)(print '\n_s)
       (exit-error( (+( 'Invalid\sMacro\sApplication\s_s macro-name )) program ))
    ) ())
    return
diff --git a/SRC/std-apply-macro-candidates.lsts b/SRC/std-apply-macro-candidates.lsts
@@ -11,11 +11,10 @@ let std-apply-macro-candidates(tctx: TContext?, mname: CString, margs: AST, cand
       if not(non-zero(t)) {
          (let new-tctx, let mctx) = std-try-destructure-macro(tctx, margs, ctype, mlhs);
          if mctx.is-some then mctx = union(mctx, Some{extract-uuids(mrhs)});
-         if mctx.is-some then t = with-location(substitute(mctx.get-or-panic, mrhs.unique), margs.location);
+         if mctx.is-some then t = with-location(substitute(mctx.get-or-panic, mrhs), margs.location);
       }
    };
    if not(non-zero(t)) then fail("Macro Application failed match during destructuring: \{mname}\n");
-   print("Applied Macro: \{mname}\nTerm: \{t}\n");
    (tctx, t) = std-infer-expr(tctx, t, false, Used, TAny);
    (tctx, t)
 );
diff --git a/SRC/std-infer-expr.lsts b/SRC/std-infer-expr.lsts
@@ -70,14 +70,14 @@ let std-infer-expr(tctx: Maybe<TContext>, term: AST, is-scoped: Bool, used: IsUs
             (_, let new-t) = std-infer-expr(tctx-inner, t, false, Tail, TAny);
             (_, let new-f) = std-infer-expr(tctx, f, false, Tail, TAny);
             if not(is(cond,new-cond)) || not(is(t,new-t)) || not(is(f,new-f))
-            then { term = mk-app(mk-app(mk-app(ifv,new-cond),new-t),new-f) };
+            then { cond = new-cond; t = new-t; f = new-f; term = mk-app(mk-app(mk-app(ifv,new-cond),new-t),new-f) };
          } else {
             (tctx, let new-cond) = std-infer-expr(tctx, cond, false, Used, TAny);
             (let tctx-t, let new-t) = std-infer-expr(tctx, t, false, Tail, TAny);
             (_, let new-f) = std-infer-expr(tctx, f, false, Tail, TAny);
             tctx = tctx-t;
             if not(is(cond,new-cond)) || not(is(t,new-t)) || not(is(f,new-f))
-            then { term = mk-app(mk-app(mk-app(ifv,new-cond),new-t),new-f) };
+            then { cond = new-cond; t = new-t; f = new-f; term = mk-app(mk-app(mk-app(ifv,new-cond),new-t),new-f) };
          };
          ascript-normal(term, typeof(t)); # TODO: use MGU to merge true and false branches
       );
@@ -98,7 +98,11 @@ let std-infer-expr(tctx: Maybe<TContext>, term: AST, is-scoped: Bool, used: IsUs
          let rough-tt = typeof(term);
          if rough-tt.is-arrow && not(rough-tt.is-open) {
             (_, let new-val) = std-infer-expr(tctx, val, is-scoped, Used, TAny);
-            if not(is(val,new-val)) then { term = mk-glb(key,new-val); };
+            if not(is(val,new-val)) then {
+               let new-term = mk-glb(key,new-val);
+               mark-var-to-def(new-term, term);
+               term = new-term;
+            };
          };
       );
       Var{key=key, token=token} => (
@@ -119,17 +123,22 @@ let std-infer-expr(tctx: Maybe<TContext>, term: AST, is-scoped: Bool, used: IsUs
          tctx = infer-ctx(tctx, lhs);
          (_, let new-inner-rhs) = std-infer-expr(tctx, inner-rhs, false, Tail, return-type);
          if not(is(inner-rhs,new-inner-rhs))
-         then { inner-rhs = new-inner-rhs; term = mk-abs(lhs, mk-app(asc,mk-app(inner-rhs,mk-atype(return-type))), misc-tt) };
+         then {
+            inner-rhs = new-inner-rhs;
+            rhs = mk-app(asc.unique,mk-app(inner-rhs,mk-atype(return-type)));
+            term = mk-abs(lhs,rhs,misc-tt);
+         };
          if not(misc-tt.is-t(c"Blob")) && not(misc-tt.is-t(c"C-FFI")) then ascript-normal(inner-rhs, return-type);
          ascript-normal(rhs, return-type);
          let domain-tt = typeof-lhs(lhs);
          ascript-normal(term, t3(c"Arrow", typeof-lhs(lhs), return-type) && misc-tt);
       );
       App{ is-cons=is-cons, l=left, r=right } => (
+         let is-macro = false;
          if is-cons {
             (tctx, let new-l) = std-infer-expr(tctx, l, false, Used, TAny);
             (tctx, let new-r) = std-infer-expr(tctx, r, false, Used, TAny);
-            if not(is(l,new-l)) || not(is(r,new-r)) then { term = mk-cons(new-l, new-r) };
+            if not(is(l,new-l)) || not(is(r,new-r)) then { l = new-l; r = new-r; term = mk-cons(new-l, new-r) };
             ascript-normal(term, if is(used, Tail) then typeof(r) else t3(c"Cons", typeof(l), typeof(r)));
          } else {
             let rt = TAny;
@@ -152,6 +161,7 @@ let std-infer-expr(tctx: Maybe<TContext>, term: AST, is-scoped: Bool, used: IsUs
 
             if index-macro-table.has(var-name-if-var(l)) {
                (tctx, term) = std-apply-macro(tctx, term);
+               is-macro = true;
             } else {
                (tctx, let new-l) = std-infer-expr(tctx, l, false, used, TAny);
                if typeof(l).is-arrow {
@@ -171,8 +181,9 @@ let std-infer-expr(tctx: Maybe<TContext>, term: AST, is-scoped: Bool, used: IsUs
             };
          };
 
-         if not(index-macro-table.has(var-name-if-var(l))) && not(is-cons) && non-zero(var-name-if-var(l)) && typeof(l).is-arrow {
+         if not(is-macro) && not(is-cons) && non-zero(var-name-if-var(l)) && typeof(l).is-arrow {
             mark-var-to-def-todo(tctx, var-name-if-var(l), typeof(r), l);
+            apply-global-callable(var-name-if-var(l),typeof(r),term);
          };
       );
       _ => fail("Unexpected Term in std-infer-expr\n\{term}\n");
diff --git a/SRC/var-to-def-index.lsts b/SRC/var-to-def-index.lsts
@@ -1,2 +1,21 @@
 
 let var-to-def-index = mk-hashtable-is(type(AST), type(AST));
+
+let var-to-def(k: AST): AST = (
+   let def = var-to-def-index.lookup(k, ASTEOF);
+   if not(non-zero(def)) {
+      exit-error( untern("Unable to Find Symlink in Context: \{k}"), k );
+   };
+   def-to-sym(def)
+);
+
+let def-to-sym(k: AST): AST = (
+   let sym = var-to-def-index.lookup(k, ASTEOF);
+   if non-zero(sym) then sym else k
+);
+
+let mark-var-to-def(k: AST, v: AST): Nil = (
+   let sym = var-to-def-index.lookup(v, ASTEOF);
+   if non-zero(sym) then v = sym;
+   var-to-def-index = var-to-def-index.bind(k, v);
+);
