Mercurial > urweb
diff src/monoize.sml @ 111:2d6116de9cca
Closure code generation almost there
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Sun, 13 Jul 2008 12:06:47 -0400 |
parents | 3739af9e727a |
children | ff13d390ec60 |
line wrap: on
line diff
--- 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)) =