# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1215965207 14400
# Node ID 2d6116de9ccad3a62000b54cbe6efd62db432bd3
# Parent  3739af9e727a8543354fbf3176a364ddbec03d40
Closure code generation almost there

diff -r 3739af9e727a -r 2d6116de9cca src/cjrize.sml
--- a/src/cjrize.sml	Sun Jul 13 11:43:57 2008 -0400
+++ b/src/cjrize.sml	Sun Jul 13 12:06:47 2008 -0400
@@ -155,6 +155,9 @@
             ((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 -r 3739af9e727a -r 2d6116de9cca src/corify.sml
--- a/src/corify.sml	Sun Jul 13 11:43:57 2008 -0400
+++ b/src/corify.sml	Sun Jul 13 12:06:47 2008 -0400
@@ -376,8 +376,13 @@
       | 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 -r 3739af9e727a -r 2d6116de9cca src/mono.sml
--- a/src/mono.sml	Sun Jul 13 11:43:57 2008 -0400
+++ b/src/mono.sml	Sun Jul 13 12:06:47 2008 -0400
@@ -54,6 +54,8 @@
        | EWrite of exp
        | ESeq of exp * exp
 
+       | EClosure of int * exp list
+
 
 withtype exp = exp' located
 
diff -r 3739af9e727a -r 2d6116de9cca src/mono_print.sml
--- a/src/mono_print.sml	Sun Jul 13 11:43:57 2008 -0400
+++ b/src/mono_print.sml	Sun Jul 13 12:06:47 2008 -0400
@@ -130,6 +130,12 @@
                               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 -r 3739af9e727a -r 2d6116de9cca src/mono_util.sml
--- a/src/mono_util.sml	Sun Jul 13 11:43:57 2008 -0400
+++ b/src/mono_util.sml	Sun Jul 13 12:06:47 2008 -0400
@@ -194,6 +194,11 @@
                          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 -r 3739af9e727a -r 2d6116de9cca src/monoize.sml
--- a/src/monoize.sml	Sun Jul 13 11:43:57 2008 -0400
+++ b/src/monoize.sml	Sun Jul 13 12:06:47 2008 -0400
@@ -79,14 +79,35 @@
 
 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 @@
                                       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 @@
           | 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 -r 3739af9e727a -r 2d6116de9cca src/tag.sml
--- a/src/tag.sml	Sun Jul 13 11:43:57 2008 -0400
+++ b/src/tag.sml	Sun Jul 13 12:06:47 2008 -0400
@@ -166,7 +166,7 @@
                 (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 -r 3739af9e727a -r 2d6116de9cca tests/link.lac
--- a/tests/link.lac	Sun Jul 13 11:43:57 2008 -0400
+++ b/tests/link.lac	Sun Jul 13 12:06:47 2008 -0400
@@ -4,6 +4,4 @@
 
 val main : {} -> xhtml = fn () => <html><body>
         <a link={ancillary ()}>Enter the unknown!</a>
-
-        <a link={ancillary ()}>Alternate route!</a>
 </body></html>