OK

Author: andrew-johnson-4

BOOTSTRAP/cli.c

@@ -5,7 +5,6 @@ import SRC/quick-prop.lsts;
 
 import SRC/substitute.lm;
 import SRC/cons-root.lsts;
-import SRC/infer-expr.lm;
 import SRC/is-special.lm;
 import SRC/global-is-seen.lm;
 import SRC/index-of-tag.lm;

SRC/index-types.lm

@@ -37,7 +37,8 @@ infer-global-context-2 := λ(: td AST). (: (
       ( (Glb( k (@( frhs (Abs( lhs (App( (Lit( ':_s _ )) (App( rhs (AType rhst) )) )) tlt )) )) )) (
       ))
       ( (Glb( k rhs )) (
-         (infer-expr( (: None Maybe<TContext>) rhs Unscoped TAny Used ))
+         (let tctx-rhs (std-infer-expr( (: None Maybe<TContext>) rhs false Used TAny )))
+         # TODO: make this rewrite terms if the subtree has changes
          (let rhst (normalize(typeof rhs)))
          (let kt (&&( rhst (t1 'GlobalVariable_s) )))
          (set global-type-context (.bind( global-type-context (.key k) kt td )))

SRC/infer-expr.lm

@@ -3,6 +3,10 @@ let mk-app(f: AST, a: AST): AST = (
    App{ close(f), close(a) }
 );
 
+let mk-cons-or-app(is-cons: U64, f: AST, a: AST): AST = (
+   App{ is-cons, close(f), close(a) }
+);
+
 let mk-cons(f: AST, a: AST): AST = (
    App{ true, close(f), close(a) }
 );

SRC/infer-global-context.lm

@@ -15,7 +15,7 @@ specialize := λ(: key String)(: ft Type)(: unify-ctx Maybe<TContext>)(: result-
          (mark-as-special( key result-type ))
          (let special-term (substitute( unify-ctx term )))
          (infer-global-context( special-term ))
-         (infer-expr( (: None Maybe<TContext>) special-term Unscoped (t1 'Specialize_s) Used ))
+         (let tctx-special (std-infer-expr( (: None Maybe<TContext>) special-term false Used TAny )))
          (set global-type-context (.bind( global-type-context key (typeof special-term) special-term )))
          (set ast-parsed-program (Seq(
             (close ast-parsed-program)

SRC/mk-app.lsts

@@ -19,7 +19,7 @@ let std-apply-macro(tctx: Maybe<TContext>, mname: CString, margs: AST): (TContex
          peeped = mtype;
       };
    };
-   let peeped-type = std-infer-peeped-arguments(tctx, margs, peep-holes);
+   (let peeped-type, _) = std-infer-peeped-arguments(tctx, margs, peep-holes);
 
    let matched = [] :: List<(Type,AST)>;
    for Tuple{mtype=first, mterm=third} in row {
@@ -45,20 +45,24 @@ let std-apply-macro(tctx: Maybe<TContext>, mname: CString, margs: AST): (TContex
    std-apply-macro-candidates(tctx, mname, margs, candidates);
 );
 
-let std-infer-peeped-arguments(tctx: Maybe<TContext>, t: AST, peep: Type): Type = (
+let std-infer-peeped-arguments(tctx: Maybe<TContext>, t: AST, peep: Type): (Type, AST) = (
    match peep {
       TGround{tag:c"Cons", parameters:[p2.. p1..]} => (
          match t {
-            App{left=left, right=right} => (
-               t3(c"Cons",
-                  std-infer-peeped-arguments(tctx, left, p1),
-                  std-infer-peeped-arguments(tctx, right, p2)
-               )
+            App{is-cons=is-cons, left=left, right=right} => (
+               (let lt, let new-left) = std-infer-peeped-arguments(tctx, left, p1);
+               (let rt, let new-right) = std-infer-peeped-arguments(tctx, right, p2);
+               if not(is(left,new-left)) || not(is(right,new-right))
+               then t = mk-cons-or-app(is-cons,new-left,new-right);
+               (t3(c"Cons",lt,rt), t)
             );
             _ => fail("std-infer-peeped-arguments expected cons term: \{t}\n");
          }
       );
-      TAny{} => ta;
-      _ => ( infer-expr(tctx, t, Unscoped, TAny, Used); typeof(t) );
+      TAny{} => (ta, t);
+      _ => (
+         (_, t) = std-infer-expr(tctx, t, false, Used, TAny);
+         (typeof(t), t);
+      );
    }
 );

SRC/specialize.lm

@@ -76,11 +76,21 @@ let std-infer-expr(tctx: Maybe<TContext>, term: AST, is-scoped: Bool, used: IsUs
       Meta{} => ascript-normal(term, t1(c"Nil"));
       Typedef{} => ();
       AType{tt=tt} => ascript-normal(term, tt);
-      Seq{left=left, right=right} => (
-         (tctx, let new-left) = std-infer-expr(tctx, left, false, Used, TAny);
-         (tctx, let new-right) = std-infer-expr(tctx, right, false, Used, TAny);
-         if not(is(left,new-left)) || not(is(right,new-right))
-         then term = mk-seq(new-left, new-right);
+      Seq{} => (
+         let seqs = [] :: List<AST>;
+         while term.is-seq { match term {
+            Seq{l=left, r=right} => (
+               (tctx, r) = std-infer-expr(tctx, r, false, Used, hint);
+               seqs = cons(r,seqs);
+               term = l;
+            );
+         }};
+         term = ASTEOF;
+         for r in seqs {
+            if non-zero(term)
+            then term = mk-seq(term, r)
+            else term = r
+         };
       );
       Glb{key=key, val=val} => (
          # TODO: remove after infer-expr.lm is ported

SRC/std-apply-macro.lsts

@@ -24,7 +24,7 @@ typecheck := λ. (: (
          (set ordered-type-exprs rst)
       ))
    )))
-   (infer-expr( (: None Maybe<TContext>) ast-parsed-program Unscoped TAny Used ))
+   (let tctx-ast (std-infer-expr( (: None Maybe<TContext>) ast-parsed-program false Used TAny )))
    (while (non-zero stack-to-specialize) (match stack-to-specialize (
       ()
       ( (LCons( (StackToSpecialize( function-name ft unify-ctx special-type )) rst )) (