Mercurial > urweb

comparison src/monoize.sml @ 111:2d6116de9cca

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Closure code generation almost there
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 12:06:47 -0400
parents 3739af9e727a
children ff13d390ec60
comparison
equal deleted inserted replaced
110:3739af9e727a 111:2d6116de9cca
77 | L.CUnit => poly () 77 | L.CUnit => poly ()
78 end 78 end
79 79
80 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) 80 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
81 81
82 fun attrifyExp (e, tAll as (t, loc)) = 82 fun attrifyExp env (e, tAll as (t, loc)) =
83 case t of 83 case #1 e of
84 L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", "attrifyString", [e]), loc) 84 L'.EClosure (fnam, args) =>
85 | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", "attrifyInt", [e]), loc) 85 let
86 | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", "attrifyFloat", [e]), loc) 86 val (_, ft, _, s) = Env.lookupENamed env fnam
87 | _ => (E.errorAt loc "Don't know how to encode attribute type"; 87 val ft = monoType env ft
88 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; 88
89 dummyExp) 89 fun attrify (args, ft, e) =
90 case (args, ft) of
91 ([], _) => e
92 | (arg :: args, (L'.TFun (t, ft), _)) =>
93 (L'.EStrcat (e,
94 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
95 attrifyExp env (arg, t)), loc)), loc)
96 | _ => (E.errorAt loc "Type mismatch encoding attribute";
97 e)
98 in
99 attrify (args, ft, (L'.EPrim (Prim.String s), loc))
100 end
101 | _ =>
102 case t of
103 L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", "attrifyString", [e]), loc)
104 | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", "attrifyInt", [e]), loc)
105 | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", "attrifyFloat", [e]), loc)
106 | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc)
107
108 | _ => (E.errorAt loc "Don't know how to encode attribute type";
109 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
110 dummyExp)
90 111
91 fun monoExp env (all as (e, loc)) = 112 fun monoExp env (all as (e, loc)) =
92 let 113 let
93 fun poly () = 114 fun poly () =
94 (E.errorAt loc "Unsupported expression"; 115 (E.errorAt loc "Unsupported expression";
153 let 174 let
154 val xp = " " ^ lowercaseFirst x ^ "=\"" 175 val xp = " " ^ lowercaseFirst x ^ "=\""
155 in 176 in
156 (L'.EStrcat (s, 177 (L'.EStrcat (s,
157 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), 178 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
158 (L'.EStrcat (attrifyExp (e, t), 179 (L'.EStrcat (attrifyExp env (e, t),
159 (L'.EPrim (Prim.String "\""), loc)), 180 (L'.EPrim (Prim.String "\""), loc)),
160 loc)), 181 loc)),
161 loc)), loc) 182 loc)), loc)
162 end) 183 end)
163 s xes 184 s xes
191 | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x, monoExp env e, monoType env t)) xes), loc) 212 | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x, monoExp env e, monoType env t)) xes), loc)
192 | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc) 213 | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc)
193 | L.EFold _ => poly () 214 | L.EFold _ => poly ()
194 | L.EWrite e => (L'.EWrite (monoExp env e), loc) 215 | L.EWrite e => (L'.EWrite (monoExp env e), loc)
195 216
196 | L.EClosure _ => raise Fail "Monoize EClosure" 217 | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp env) es), loc)
197 end 218 end
198 219
199 fun monoDecl env (all as (d, loc)) = 220 fun monoDecl env (all as (d, loc)) =
200 let 221 let
201 fun poly () = 222 fun poly () =