Mercurial > urweb

comparison src/mono_reduce.sml @ 829:20fe00fd81da

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Substring functions; fix a nasty MonoReduce pattern match substitution bug
author Adam Chlipala <adamc@hcoop.net>
date Sat, 30 May 2009 13:29:00 -0400
parents 497c7dbcc695
children e8594cfa3236
comparison
equal deleted inserted replaced
828:14a6c0971d89 829:20fe00fd81da
82 | ERecv _ => true 82 | ERecv _ => true
83 | ESleep _ => true 83 | ESleep _ => true
84 84
85 85
86 val liftExpInExp = Monoize.liftExpInExp 86 val liftExpInExp = Monoize.liftExpInExp
87
88 fun multiLift n e =
89 case n of
90 0 => e
91 | _ => multiLift (n - 1) (liftExpInExp 0 e)
87 92
88 val subExpInExp' = 93 val subExpInExp' =
89 U.Exp.mapB {typ = fn t => t, 94 U.Exp.mapB {typ = fn t => t,
90 exp = fn (xn, rep) => fn e => 95 exp = fn (xn, rep) => fn e =>
91 case e of 96 case e of
417 case match ([], p, e') of 422 case match ([], p, e') of
418 No => search pes 423 No => search pes
419 | Maybe => push () 424 | Maybe => push ()
420 | Yes subs => 425 | Yes subs =>
421 let 426 let
422 val body = foldr (fn (e, body) => subExpInExp (0, e) body) body subs 427 val (body, remaining) =
428 foldl (fn (e, (body, remaining)) =>
429 (subExpInExp (0, multiLift remaining e) body, remaining - 1))
430 (body, length subs - 1) subs
423 val r = reduceExp env body 431 val r = reduceExp env body
424 in 432 in
433 (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*)
425 (*Print.prefaces "ECase" 434 (*Print.prefaces "ECase"
426 [("body", MonoPrint.p_exp env' body), 435 [("old", MonoPrint.p_exp env body),
436 ("body", MonoPrint.p_exp env body),
427 ("r", MonoPrint.p_exp env r)];*) 437 ("r", MonoPrint.p_exp env r)];*)
428 #1 r 438 #1 r
429 end 439 end
430 in 440 in
431 search pes 441 search pes
531 | ESignalBind ((ESignalReturn e1, loc), e2) => 541 | ESignalBind ((ESignalReturn e1, loc), e2) =>
532 #1 (reduceExp env (EApp (e2, e1), loc)) 542 #1 (reduceExp env (EApp (e2, e1), loc))
533 543
534 | _ => e 544 | _ => e
535 in 545 in
536 (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) 546 (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
547 ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
537 r 548 r
538 end 549 end
539 550
540 and bind (env, b) = 551 and bind (env, b) =
541 case b of 552 case b of