Mercurial > urweb

comparison src/mono_reduce.sml @ 341:389399d65331

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Crud update form
author Adam Chlipala <adamc@hcoop.net>
date Sun, 14 Sep 2008 19:03:55 -0400
parents e976b187d73a
children 7abb28e9d51f
comparison
equal deleted inserted replaced
340:5ccb1c6412e4 341:389399d65331
109 e 109 e
110 | _ => e, 110 | _ => e,
111 bind = fn (lower, U.Exp.RelE _) => lower+1 111 bind = fn (lower, U.Exp.RelE _) => lower+1
112 | (lower, _) => lower} 112 | (lower, _) => lower}
113 113
114 val swapExpVarsPat =
115 U.Exp.mapB {typ = fn t => t,
116 exp = fn (lower, len) => fn e =>
117 case e of
118 ERel xn =>
119 if xn = lower then
120 ERel (lower + 1)
121 else if xn >= lower + 1 andalso xn < lower + 1 + len then
122 ERel (xn - 1)
123 else
124 e
125 | _ => e,
126 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len)
127 | (st, _) => st}
128
114 datatype result = Yes of E.env | No | Maybe 129 datatype result = Yes of E.env | No | Maybe
115 130
116 fun match (env, p : pat, e : exp) = 131 fun match (env, p : pat, e : exp) =
117 case (#1 p, #1 e) of 132 case (#1 p, #1 e) of
118 (PWild, _) => Yes env 133 (PWild, _) => Yes env
270 if impure e2 then 285 if impure e2 then
271 #1 (reduceExp env (ELet (x, t, e2, e1), loc)) 286 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
272 else 287 else
273 #1 (reduceExp env (subExpInExp (0, e2) e1))) 288 #1 (reduceExp env (subExpInExp (0, e2) e1)))
274 289
275 | ECase (disc, pes, _) => 290 | ECase (e', pes, {disc, result}) =>
276 let 291 let
292 fun push () =
293 case result of
294 (TFun (dom, result), loc) =>
295 if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then
296 EAbs ("_", dom, result,
297 (ECase (liftExpInExp 0 e',
298 map (fn (p, (EAbs (_, _, _, e), _)) =>
299 (p, swapExpVarsPat (0, patBinds p) e)
300 | _ => raise Fail "MonoReduce ECase") pes,
301 {disc = disc, result = result}), loc))
302 else
303 e
304 | _ => e
305
277 fun search pes = 306 fun search pes =
278 case pes of 307 case pes of
279 [] => e 308 [] => push ()
280 | (p, body) :: pes => 309 | (p, body) :: pes =>
281 case match (env, p, disc) of 310 case match (env, p, e') of
282 No => search pes 311 No => search pes
283 | Maybe => e 312 | Maybe => push ()
284 | Yes env => #1 (reduceExp env body) 313 | Yes env => #1 (reduceExp env body)
285 in 314 in
286 search pes 315 search pes
287 end 316 end
288 317