rename LamList to LamArgs

fn/rewrite/infer.fn

@@ -0,0 +1,179 @@
+let
+    typedef typeExp {
+          varType(typeExp)
+        | operType(list(char), list(typeExp))
+        | nullType
+    }
+    typedef copyEnv {
+          cpEnv(typeExp, typeExp, copyEnv)
+        | nullCpEnv
+    }
+    typedef typeCheckEnv {
+          tcEnv(list(char), typeExp, typeCheckEnv)
+        | nullTcEnv
+    }
+    typedef ExpClass {
+          ideClass(list(char))
+        | condClass(ExpClass, ExpClass, ExpClass)
+        | lambClass(list(char), ExpClass)
+        | appClass(ExpClass, ExpClass)
+        | blockClass(DeclClass, ExpClass)
+    }
+    typedef DeclClass {
+          defClass(list(char), ExpClass)
+        | seqClass(DeclClass, DeclClass)
+        | recClass(Decl)
+    }
+    fn newTypeVar() { varType(nullType) }
+    fn prune {
+        (x = varType(nullType)) { x }
+        (varType(x)) { prune(x) }
+        (x) { x }
+    }
+    fn occursInType {
+        (var, type) {
+            switch(prune(type)) {
+                (x = varType(_)) { var == x }
+                (operType(_, args)) { occursInTypeList(var, args) }
+            }
+        }
+    }
+    fn occursInTypeList {
+        (_, []) { false }
+        (var, h @ t) { occursInType(var, h) or occursInTypeList(var, t) }
+    }
+    fn unifyType(exp1, exp2) {
+        switch (prune(exp1), prune(exp2)) {
+            (exp1=varType(_), exp2) {
+                if (occursInType(exp1, exp2)) {
+                    exp1 == exp2
+                } else {
+                    varType(exp2); // exp1.instance := exp2
+                    true
+                }
+            }
+            (exp1, exp2=varType(_)) {
+                unifyType(exp2, exp1)
+            }
+            (operType(ide, args1), operType(ide, args2)) {
+                unifyArgs(args1, args2)
+            }
+            (_, _) {
+                false
+            }
+        }
+    }
+    fn unifyArgs {
+        ([], []) { true }
+        (h1 @ t1, h2 @ t2) { unifyType(h1, h2) and unifyArgs(t1, t2) }
+        (_, _) { false }
+    }
+    fn isGeneric(var, ng) { not occursInTypeList(var, ng) }
+    fn freshVar {
+        (typeVar, nullCpEnv, envt) {
+            fn (fresh) {
+                #(fresh, copyEnv(fresh, typevar, envt))
+            } (newTypeVar())
+        }
+        (typeVar, cpEnv(old, new, parent), topEnv) {
+            if (typeVar == old) {
+                (new, topEnv)
+            } else {
+                freshVar(typeVar, parent, topEnv)
+            }
+        }
+    }
+    fn fresh(typeExp, ng, envt) {
+        switch(prune(typeExp)) {
+            (x = varType(_)) {
+                if (isGeneric(x, ng)) {
+                    freshVar(x, envt, envt)
+                } else { x }
+            }
+            (operType(ide, args)) {
+                operType(ide, freshList(args, ng, envt))
+            }
+        }
+    }
+    fn freshList {
+        ([], _, _) { [] }
+        (h @ t, ng, envt) {
+            fresh(h, ng, envt) @ freshList(t, ng, envt)
+        }
+    }
+    fn freshType(typeExp, ng) {
+        fresh(typeExp, ng, nullCpEnv)
+    }
+    fn retrieve {
+        (ide, tcEnv(ide, exp, _), ng) { freshType(exp, ng) }
+        (_, nullTcEnv, _) { error("unbound ide") }
+        (ide, tcEnv(_, _, tail), ng) { retrieve(ide, tail, ng) }
+    }
+    fn funType(dom, cod) { operType("->", [dom, cod]) }
+    fn analyzeExp {
+        (expClass(ide), envt, ng) { retrieve(ide, envt, ng) }
+        (condClass(test, cons, alt), envt, ng) {
+            unifyType(test, boolType) and
+            unifyType(analyzeExp(cons, envt, ng), analyzeExp(alt, envt, ng))
+            // return type of cons
+        }
+        (lambClass(binder, body), envt, ng) {
+            fn (typeOfBinder) {
+                funType(typeOfBinder,
+                    analyzeExp(body, tcEnv(binder, typeOfBinder, envt),
+                        typeOfBinder @ ng))
+            } (newTypeVar())
+        }
+        (appClass(fun, arg), envt, ng) {
+            fn (typeOfRes) {
+                unifyType(
+                    analyzeExp(fun, envt, ng),
+                    funType(analyzeExp(arg, envt, ng), typeOfRes));
+                typeOfRes
+            } (newTypeVar())
+        }
+        (blockClass(decl, scope), envt, ng) {
+            analyzeExp(scope, analyzeDecl(decl, envt, ng), ng)
+        }
+    }
+    fn analyzeDecl {
+        (defClass(binder, def), envt, ng) {
+            tcEnv(binder, analyzeExp(def, envt, ng), envt)
+        }
+        (seqClass(first, second), envt, ng) {
+            analyzeDecl(second, anayzeDecl(first, envt, ng), ng);
+        }
+        (recClass(rec), envt, ng) {
+            let
+                #(env2, ng2) = analyzeRecDeclBind(rec, envt, ng);
+            in
+                analyzeRecDecl(rec, env2, ng2);
+                env2
+        }
+    }
+    fn analyzeRecDeclBind {
+        (defClass(binder, _), envt, ng) {
+            fn (fresh) {
+                #(tcEnv(binder, fresh, envt), fresh @ ng)
+            } (newTypeVar())
+        }
+        (seqClass(first, second), envt, ng) {
+            let
+                #(env1, ng1) = analyzeRecDeclBind(first, envt, ng);
+            in
+                analyzeRecDeclBind(second, env1, ng1);
+        }
+    }
+    fn analyzeRecDecl {
+        (defClass(binder, def), envt, ng) {
+            unifyType(retrieve(binder, envt, ng),
+                      analyzeExp(def, envt, ng))
+        }
+        (seqClass(first, second), envt, ng) {
+            analyzeRecDecl(first, envt, ng) and
+                analyzeRecDecl(second, envt, ng)
+        }
+        (recClass(rec), envt, ng) {
+            analyzeRec(rec, envt, ng)
+        }
+    }

fn/rewrite/normalize.fn

@@ -0,0 +1,144 @@
+let
+    link "listutils.fn" as list;
+
+    typedef expr {
+        lambda(list(expr), expr) |
+        let_expr(expr, expr, expr) |
+        if_expr(expr, expr, expr) |
+        apply(expr, list(expr)) |
+        value(number) |
+        var_expr(list(char)) |
+        nada
+    }
+
+    print expr {
+        (x=lambda(args, expr)) {
+            puts("(lambda (");
+            list.map (fn(e) { print(e) }, args);
+            puts(") ");
+            print(expr);
+            puts(")");
+            x;
+        }
+        (x=let_expr(e1, e2, e3)) {
+            puts("(let (");
+            print(e1);
+            print(e2);
+            puts(") ");
+            print(e3);
+            puts(")");
+            x;
+        }
+        (x=if_expr(e1, e2, e3)) {
+            puts("(if ");
+            print(e1);
+            print(e2);
+            print(e3);
+            puts(")");
+            x;
+        }
+        (x=apply(e1, args)) {
+            puts("(");
+            print(e1);
+            list.map (fn(e) { print(e) }, args);
+            puts(")");
+            x;
+        }
+        (x=value(i)) {
+            putn(i);
+            x;
+        }
+        (x=var_expr(chars)) {
+            puts(chars);
+            x;
+        }
+        (x=nada) {
+            puts("nil");
+            x;
+        }
+    }
+
+    fn debug(s) {
+        if (false) {
+            puts(s);
+            putc('\n');
+            0;
+        } else {
+            0;
+        }
+    }
+
+    fn gensym() { debug("gensym"); var_expr("gen") }
+
+    fn normalize_term (M) { debug("normalize_term"); normalize(M, fn (x) { x }) }
+
+    fn normalize {
+        (lambda(params, body), k) {
+            debug("normalize lambda");
+            k(lambda(params, normalize_term(body)))
+        }
+        (let_expr(x, M1, M2), k) {
+            debug("normalize let");
+            normalize(M1, fn (N1) { let_expr(x, N1, normalize(M2, k)) })
+        }
+        (if_expr(M1, M2, M3), k) {
+            debug("normalize if");
+            normalize_name(M1, fn (t) {
+                k(if_expr(t, normalize_term(M2), normalize_term(M3)))
+            })
+        }
+        (apply(Fn, Ms), k) {
+            debug("normalize apply");
+            normalize_name(Fn, fn (t) {
+                normalize_names(Ms, fn (ts) {
+                    k(apply(t, [ts]))
+                })
+            })
+        }
+        (v=value(_), k) | (v=var_expr(_), k) {
+            debug("normalize value");
+            k(v)
+        }
+        (nada, k) {
+            debug("normalize nada");
+            k(nada)
+        }
+    }
+
+    fn normalize_name(M, k) {
+        debug("normalize_name");
+        normalize(M, fn {
+            (N=value(_)) {
+                k(N)
+            }
+            (N) {
+                let
+                    t = gensym();
+                in
+                    let_expr(t, N, k(t)) // !
+            }
+        })
+    }
+
+    fn normalize_names {
+        ([], k) {
+            debug("normalize_names nil");
+            k(nada)
+        }
+        (H @ T, k) {
+            debug("normalize_names non-nil");
+            normalize_name(H, fn (t) {
+                normalize_names(T, fn (ts) {
+                    k(apply(t, [ts]))
+                })
+            })
+        }
+    }
+in
+    print(
+        normalize_term(
+            apply(lambda([var_expr("a")],
+                    if_expr(var_expr("a"),
+                        var_expr("b"),
+                        var_expr("c"))),
+                    [value(1)])))