Mercurial > urweb
comparison src/mono_reduce.sml @ 800:e92cfac1608f
Proper lifting of MonoEnv stored expressions; avoidance of onchange clobbering
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Thu, 14 May 2009 13:18:31 -0400 |
parents | a28982de5645 |
children | 5f49a6b759cb |
comparison
equal
deleted
inserted
replaced
799:9330ba3a2799 | 800:e92cfac1608f |
---|---|
407 [] => push () | 407 [] => push () |
408 | (p, body) :: pes => | 408 | (p, body) :: pes => |
409 case match (env, p, e') of | 409 case match (env, p, e') of |
410 No => search pes | 410 No => search pes |
411 | Maybe => push () | 411 | Maybe => push () |
412 | Yes env => #1 (reduceExp env body) | 412 | Yes env' => |
413 let | |
414 val r = reduceExp env' body | |
415 in | |
416 (*Print.prefaces "ECase" | |
417 [("body", MonoPrint.p_exp env' body), | |
418 ("r", MonoPrint.p_exp env r)];*) | |
419 #1 r | |
420 end | |
413 in | 421 in |
414 search pes | 422 search pes |
415 end | 423 end |
416 | 424 |
417 | EField ((ERecord xes, _), x) => | 425 | EField ((ERecord xes, _), x) => |
441 EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) | 449 EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) |
442 | 450 |
443 | ELet (x, t, e', b) => | 451 | ELet (x, t, e', b) => |
444 let | 452 let |
445 fun doSub () = | 453 fun doSub () = |
446 #1 (reduceExp env (subExpInExp (0, e') b)) | 454 let |
455 val r = subExpInExp (0, e') b | |
456 in | |
457 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'), | |
458 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), | |
459 ("r", MonoPrint.p_exp env r)];*) | |
460 #1 (reduceExp env r) | |
461 end | |
447 | 462 |
448 fun trySub () = | 463 fun trySub () = |
449 case t of | 464 case t of |
450 (TFfi ("Basis", "string"), _) => doSub () | 465 (TFfi ("Basis", "string"), _) => doSub () |
451 | (TSignal _, _) => e | 466 | (TSignal _, _) => e |