Mercurial > urweb

comparison src/monoize.sml @ 178:eb3f9913bf31

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
First part of getting cases through monoize
author Adam Chlipala <adamc@hcoop.net>
date Sun, 03 Aug 2008 09:26:49 -0400
parents 5d030ee143e2
children 3bbed533fbd2
comparison
equal deleted inserted replaced
177:5d030ee143e2 178:eb3f9913bf31
158 158
159 fun setRadioGroup (t : t, x) = {radioGroup = SOME x} 159 fun setRadioGroup (t : t, x) = {radioGroup = SOME x}
160 160
161 end 161 end
162 162
163 fun monoPatCon pc =
164 case pc of
165 L.PConVar n => L'.PConVar n
166 | L.PConFfi mx => L'.PConFfi mx
167
168 fun monoPat (p, loc) =
169 case p of
170 L.PWild => (L'.PWild, loc)
171 | L.PVar x => (L'.PVar x, loc)
172 | L.PPrim p => (L'.PPrim p, loc)
173 | L.PCon (pc, po) => (L'.PCon (monoPatCon pc, Option.map monoPat po), loc)
174 | L.PRecord xps => (L'.PRecord (map (fn (x, p) => (x, monoPat p)) xps), loc)
175
163 fun monoExp (env, st) (all as (e, loc)) = 176 fun monoExp (env, st) (all as (e, loc)) =
164 let 177 let
165 fun poly () = 178 fun poly () =
166 (E.errorAt loc "Unsupported expression"; 179 (E.errorAt loc "Unsupported expression";
167 Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; 180 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
169 in 182 in
170 case e of 183 case e of
171 L.EPrim p => (L'.EPrim p, loc) 184 L.EPrim p => (L'.EPrim p, loc)
172 | L.ERel n => (L'.ERel n, loc) 185 | L.ERel n => (L'.ERel n, loc)
173 | L.ENamed n => (L'.ENamed n, loc) 186 | L.ENamed n => (L'.ENamed n, loc)
174 | L.ECon _ => raise Fail "Monoize ECon" 187 | L.ECon (n, eo) => (L'.ECon (n, Option.map (monoExp (env, st)) eo), loc)
175 | L.EFfi mx => (L'.EFfi mx, loc) 188 | L.EFfi mx => (L'.EFfi mx, loc)
176 | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp (env, st)) es), loc) 189 | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp (env, st)) es), loc)
177 190
178 | L.EApp ( 191 | L.EApp (
179 (L.ECApp ( 192 (L.ECApp (
448 monoType env t)) xes), loc) 461 monoType env t)) xes), loc)
449 | L.EField (e, x, _) => (L'.EField (monoExp (env, st) e, monoName env x), loc) 462 | L.EField (e, x, _) => (L'.EField (monoExp (env, st) e, monoName env x), loc)
450 | L.ECut _ => poly () 463 | L.ECut _ => poly ()
451 | L.EFold _ => poly () 464 | L.EFold _ => poly ()
452 465
453 | L.ECase _ => raise Fail "Monoize ECase" 466 | L.ECase (e, pes, t) => (L'.ECase (monoExp (env, st) e,
467 map (fn (p, e) => (monoPat p, monoExp (env, st) e)) pes,
468 monoType env t), loc)
454 469
455 | L.EWrite e => (L'.EWrite (monoExp (env, st) e), loc) 470 | L.EWrite e => (L'.EWrite (monoExp (env, st) e), loc)
456 471
457 | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp (env, st)) es), loc) 472 | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp (env, st)) es), loc)
458 end 473 end