Mercurial > urweb
comparison src/mono_reduce.sml @ 814:3f3b211f9bca
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 |