Mercurial > urweb

comparison src/monoize.sml @ 182:d11754ffe252

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Compiled pattern matching to C
author Adam Chlipala <adamc@hcoop.net>
date Sun, 03 Aug 2008 12:43:20 -0400
parents 3bbed533fbd2
children c0ea24dcb86f
comparison
equal deleted inserted replaced
181:31dfab1d4050 182:d11754ffe252
210 (((L'.PCon (L'.PConVar n, NONE), loc), 210 (((L'.PCon (L'.PConVar n, NONE), loc),
211 (L'.EPrim (Prim.String x), loc)), 211 (L'.EPrim (Prim.String x), loc)),
212 fm) 212 fm)
213 | SOME t => 213 | SOME t =>
214 let 214 let
215 val (arg, fm) = fooify fm ((L'.ERel 0, loc), 215 val t = monoType env t
216 monoType env t) 216 val (arg, fm) = fooify fm ((L'.ERel 0, loc), t)
217 in 217 in
218 (((L'.PCon (L'.PConVar n, SOME (L'.PVar "a", loc)), loc), 218 (((L'.PCon (L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc),
219 (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc), 219 (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc),
220 arg), loc)), 220 arg), loc)),
221 fm) 221 fm)
222 end) 222 end)
223 fm xncs 223 fm xncs
231 (L'.EAbs ("x", 231 (L'.EAbs ("x",
232 dom, 232 dom,
233 ran, 233 ran,
234 (L'.ECase ((L'.ERel 0, loc), 234 (L'.ECase ((L'.ERel 0, loc),
235 branches, 235 branches,
236 ran), loc)), loc), 236 {disc = dom,
237 result = ran}), loc)), loc),
237 "")], loc), 238 "")], loc),
238 fm) 239 fm)
239 end 240 end
240 241
241 val (fm, n) = Fm.lookup fm fk i makeDecl 242 val (fm, n) = Fm.lookup fm fk i makeDecl
282 fun monoPatCon pc = 283 fun monoPatCon pc =
283 case pc of 284 case pc of
284 L.PConVar n => L'.PConVar n 285 L.PConVar n => L'.PConVar n
285 | L.PConFfi mx => L'.PConFfi mx 286 | L.PConFfi mx => L'.PConFfi mx
286 287
287 fun monoPat (p, loc) = 288 fun monoPat env (p, loc) =
288 case p of 289 case p of
289 L.PWild => (L'.PWild, loc) 290 L.PWild => (L'.PWild, loc)
290 | L.PVar x => (L'.PVar x, loc) 291 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
291 | L.PPrim p => (L'.PPrim p, loc) 292 | L.PPrim p => (L'.PPrim p, loc)
292 | L.PCon (pc, po) => (L'.PCon (monoPatCon pc, Option.map monoPat po), loc) 293 | L.PCon (pc, po) => (L'.PCon (monoPatCon pc, Option.map (monoPat env) po), loc)
293 | L.PRecord xps => (L'.PRecord (map (fn (x, p) => (x, monoPat p)) xps), loc) 294 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
294 295
295 fun monoExp (env, st, fm) (all as (e, loc)) = 296 fun monoExp (env, st, fm) (all as (e, loc)) =
296 let 297 let
297 fun poly () = 298 fun poly () =
298 (E.errorAt loc "Unsupported expression"; 299 (E.errorAt loc "Unsupported expression";
665 ((L'.EField (e, monoName env x), loc), fm) 666 ((L'.EField (e, monoName env x), loc), fm)
666 end 667 end
667 | L.ECut _ => poly () 668 | L.ECut _ => poly ()
668 | L.EFold _ => poly () 669 | L.EFold _ => poly ()
669 670
670 | L.ECase (e, pes, t) => 671 | L.ECase (e, pes, {disc, result}) =>
671 let 672 let
672 val (e, fm) = monoExp (env, st, fm) e 673 val (e, fm) = monoExp (env, st, fm) e
673 val (pes, fm) = ListUtil.foldlMap 674 val (pes, fm) = ListUtil.foldlMap
674 (fn ((p, e), fm) => 675 (fn ((p, e), fm) =>
675 let 676 let
676 val (e, fm) = monoExp (env, st, fm) e 677 val (e, fm) = monoExp (env, st, fm) e
677 in 678 in
678 ((monoPat p, e), fm) 679 ((monoPat env p, e), fm)
679 end) fm pes 680 end) fm pes
680 in 681 in
681 ((L'.ECase (e, pes, monoType env t), loc), fm) 682 ((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm)
682 end 683 end
683 684
684 | L.EWrite e => 685 | L.EWrite e =>
685 let 686 let
686 val (e, fm) = monoExp (env, st, fm) e 687 val (e, fm) = monoExp (env, st, fm) e