Closure code generation almost there

8 files changed, 54 insertions, 14 deletions

diff --git a/src/cjrize.sml b/src/cjrize.sml
index 52b1b4ac..558fac0b 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -155,6 +155,9 @@ fun cifyExp ((e, loc), sm) =
             ((L'.ESeq (e1, e2), loc), sm)
         end
 
+      | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation";
+                         (dummye, sm))
+
 fun cifyDecl ((d, loc), sm) =
     case d of
         L.DVal (x, n, t, e, _) =>
diff --git a/src/corify.sml b/src/corify.sml
index 9c44140d..55d9a95a 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -376,8 +376,13 @@ fun corifyDecl ((d, loc : EM.span), st) =
       | L.DVal (x, n, t, e) =>
         let
             val (st, n) = St.bindVal st x n
+            val s =
+                if String.isPrefix "wrap_" x then
+                    String.extract (x, 5, NONE)
+                else
+                    x
         in
-            ([(L'.DVal (x, n, corifyCon st t, corifyExp st e, x), loc)], st)
+            ([(L'.DVal (x, n, corifyCon st t, corifyExp st e, s), loc)], st)
         end
                                                                         
       | L.DSgn _ => ([], st)
diff --git a/src/mono.sml b/src/mono.sml
index 913650fa..4092891e 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -54,6 +54,8 @@ datatype exp' =
        | EWrite of exp
        | ESeq of exp * exp
 
+       | EClosure of int * exp list
+
 
 withtype exp = exp' located
 
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a936c146..07065b3a 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -130,6 +130,12 @@ fun p_exp' par env (e, _) =
                               space,
                               p_exp env e2]
 
+      | EClosure (n, es) => box [string "CLOSURE(",
+                                 p_enamed env n,
+                                 p_list_sep (string "") (fn e => box [string ", ",
+                                                                      p_exp env e]) es,
+                                 string ")"]
+
 and p_exp env = p_exp' false env
 
 fun p_decl env ((d, _) : decl) =
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 1a7c8f5b..0d5211cf 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -194,6 +194,11 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                          S.map2 (mfe ctx e2,
                               fn e2' =>
                                  (ESeq (e1', e2'), loc)))
+
+              | EClosure (n, es) =>
+                S.map2 (ListUtil.mapfold (mfe ctx) es,
+                     fn es' =>
+                        (EClosure (n, es'), loc))
     in
         mfe
     end
diff --git a/src/monoize.sml b/src/monoize.sml
index 2e21a2bf..266a031a 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -79,14 +79,35 @@ fun monoType env (all as (c, loc)) =
 
 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
 
-fun attrifyExp (e, tAll as (t, loc)) =
-    case t of
-        L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", "attrifyString", [e]), loc)
-      | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", "attrifyInt", [e]), loc)
-      | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", "attrifyFloat", [e]), loc)
-      | _ => (E.errorAt loc "Don't know how to encode attribute type";
-              Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
-              dummyExp)
+fun attrifyExp env (e, tAll as (t, loc)) =
+        case #1 e of
+            L'.EClosure (fnam, args) =>
+            let
+                val (_, ft, _, s) = Env.lookupENamed env fnam
+                val ft = monoType env ft
+
+                fun attrify (args, ft, e) =
+                    case (args, ft) of
+                        ([], _) => e
+                      | (arg :: args, (L'.TFun (t, ft), _)) =>
+                        (L'.EStrcat (e,
+                                     (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
+                                                  attrifyExp env (arg, t)), loc)), loc)
+                      | _ => (E.errorAt loc "Type mismatch encoding attribute";
+                              e)
+            in
+                attrify (args, ft, (L'.EPrim (Prim.String s), loc))
+            end
+          | _ =>
+            case t of
+                L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", "attrifyString", [e]), loc)
+              | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", "attrifyInt", [e]), loc)
+              | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", "attrifyFloat", [e]), loc)
+              | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc)
+
+              | _ => (E.errorAt loc "Don't know how to encode attribute type";
+                      Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
+                      dummyExp)
 
 fun monoExp env (all as (e, loc)) =
     let
@@ -155,7 +176,7 @@ fun monoExp env (all as (e, loc)) =
                                       in
                                           (L'.EStrcat (s,
                                                        (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
-                                                                    (L'.EStrcat (attrifyExp (e, t),
+                                                                    (L'.EStrcat (attrifyExp env (e, t),
                                                                                  (L'.EPrim (Prim.String "\""), loc)),
                                                                      loc)),
                                                         loc)), loc)
@@ -193,7 +214,7 @@ fun monoExp env (all as (e, loc)) =
           | L.EFold _ => poly ()
           | L.EWrite e => (L'.EWrite (monoExp env e), loc)
 
-          | L.EClosure _ => raise Fail "Monoize EClosure"
+          | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp env) es), loc)
     end
 
 fun monoDecl env (all as (d, loc)) =
diff --git a/src/tag.sml b/src/tag.sml
index a244c294..038572b6 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -166,7 +166,7 @@ fun tag file =
                 (newDs @ [d], (env, count, tags))
             end
 
-        val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count, IM.empty) file
+        val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty) file
     in
         file
     end
diff --git a/tests/link.lac b/tests/link.lac
index 4e2918e0..8d806c54 100644
--- a/tests/link.lac
+++ b/tests/link.lac
@@ -4,6 +4,4 @@ val ancillary : {} -> xhtml = fn () => <html>
 
 val main : {} -> xhtml = fn () => <html><body>
         <a link={ancillary ()}>Enter the unknown!</a>
-
-        <a link={ancillary ()}>Alternate route!</a>
 </body></html>