Mercurial > urweb

comparison src/mono_reduce.sml @ 814:3f3b211f9bca

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix argument ordering bug in fuse; fix case subsitution bug in MonoReduce
author Adam Chlipala <adamc@hcoop.net>
date Sun, 17 May 2009 14:36:55 -0400
parents 5f49a6b759cb
children 493f44759879
comparison
equal deleted inserted replaced
813:7b380e2b9e68 814:3f3b211f9bca
138 e 138 e
139 | _ => e, 139 | _ => e,
140 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len) 140 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len)
141 | (st, _) => st} 141 | (st, _) => st}
142 142
143 datatype result = Yes of E.env | No | Maybe 143 datatype result = Yes of exp list | No | Maybe
144 144
145 fun match (env, p : pat, e : exp) = 145 fun match (env, p : pat, e : exp) =
146 case (#1 p, #1 e) of 146 case (#1 p, #1 e) of
147 (PWild, _) => Yes env 147 (PWild, _) => Yes env
148 | (PVar (x, t), _) => Yes (E.pushERel env x t (SOME e)) 148 | (PVar (x, t), _) => Yes (e :: env)
149 149
150 | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) => 150 | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
151 if String.isPrefix s' s then 151 if String.isPrefix s' s then
152 Maybe 152 Maybe
153 else 153 else
404 404
405 fun search pes = 405 fun search pes =
406 case pes of 406 case pes of
407 [] => push () 407 [] => push ()
408 | (p, body) :: pes => 408 | (p, body) :: pes =>
409 case match (env, p, e') of 409 case match ([], p, e') of
410 No => search pes 410 No => search pes
411 | Maybe => push () 411 | Maybe => push ()
412 | Yes env' => 412 | Yes subs =>
413 let 413 let
414 val r = reduceExp env' body 414 val body = foldr (fn (e, body) => subExpInExp (0, e) body) body subs
415 val r = reduceExp env body
415 in 416 in
416 (*Print.prefaces "ECase" 417 (*Print.prefaces "ECase"
417 [("body", MonoPrint.p_exp env' body), 418 [("body", MonoPrint.p_exp env' body),
418 ("r", MonoPrint.p_exp env r)];*) 419 ("r", MonoPrint.p_exp env r)];*)
419 #1 r 420 #1 r