93 | pattern_key _ = raise (Compile "pattern reduces to variable") |
93 | pattern_key _ = raise (Compile "pattern reduces to variable") |
94 |
94 |
95 (*Returns true iff at most 0 .. (free-1) occur unbound. therefore |
95 (*Returns true iff at most 0 .. (free-1) occur unbound. therefore |
96 check_freevars 0 t iff t is closed*) |
96 check_freevars 0 t iff t is closed*) |
97 fun check_freevars free (Var x) = x < free |
97 fun check_freevars free (Var x) = x < free |
98 | check_freevars free (Const c) = true |
98 | check_freevars free (Const _) = true |
99 | check_freevars free (App (u, v)) = check_freevars free u andalso check_freevars free v |
99 | check_freevars free (App (u, v)) = check_freevars free u andalso check_freevars free v |
100 | check_freevars free (Abs m) = check_freevars (free+1) m |
100 | check_freevars free (Abs m) = check_freevars (free+1) m |
101 | check_freevars free (Computed t) = check_freevars free t |
101 | check_freevars free (Computed t) = check_freevars free t |
102 |
102 |
103 fun compile cache_patterns const_arity eqs = |
103 fun compile _ _ eqs = |
104 let |
104 let |
105 fun check p r = if check_freevars p r then () else raise Compile ("unbound variables in rule") |
105 fun check p r = if check_freevars p r then () else raise Compile ("unbound variables in rule") |
106 fun check_guard p (Guard (a,b)) = (check p a; check p b) |
106 fun check_guard p (Guard (a,b)) = (check p a; check p b) |
107 fun clos_of_guard (Guard (a,b)) = (clos_of_term a, clos_of_term b) |
107 fun clos_of_guard (Guard (a,b)) = (clos_of_term a, clos_of_term b) |
108 val eqs = map (fn (guards, p, r) => let val pcount = count_patternvars p val _ = map (check_guard pcount) (guards) val _ = check pcount r in |
108 val eqs = map (fn (guards, p, r) => let val pcount = count_patternvars p val _ = map (check_guard pcount) (guards) val _ = check pcount r in |
159 | _ => NONE |
159 | _ => NONE |
160 |
160 |
161 and weak_reduce (false, prog, stack, Closure (e, CApp (a, b))) = Continue (false, prog, SAppL (Closure (e, b), stack), Closure (e, a)) |
161 and weak_reduce (false, prog, stack, Closure (e, CApp (a, b))) = Continue (false, prog, SAppL (Closure (e, b), stack), Closure (e, a)) |
162 | weak_reduce (false, prog, SAppL (b, stack), Closure (e, CAbs m)) = Continue (false, prog, stack, Closure (b::e, m)) |
162 | weak_reduce (false, prog, SAppL (b, stack), Closure (e, CAbs m)) = Continue (false, prog, stack, Closure (b::e, m)) |
163 | weak_reduce (false, prog, stack, Closure (e, CVar n)) = Continue (false, prog, stack, case nth e n of CDummy => CVar n | r => r) |
163 | weak_reduce (false, prog, stack, Closure (e, CVar n)) = Continue (false, prog, stack, case nth e n of CDummy => CVar n | r => r) |
164 | weak_reduce (false, prog, stack, Closure (e, c as CConst _)) = Continue (false, prog, stack, c) |
164 | weak_reduce (false, prog, stack, Closure (_, c as CConst _)) = Continue (false, prog, stack, c) |
165 | weak_reduce (false, prog, stack, clos) = |
165 | weak_reduce (false, prog, stack, clos) = |
166 (case match_closure prog clos of |
166 (case match_closure prog clos of |
167 NONE => Continue (true, prog, stack, clos) |
167 NONE => Continue (true, prog, stack, clos) |
168 | SOME r => Continue (false, prog, stack, r)) |
168 | SOME r => Continue (false, prog, stack, r)) |
169 | weak_reduce (true, prog, SAppR (a, stack), b) = Continue (false, prog, stack, CApp (a,b)) |
169 | weak_reduce (true, prog, SAppR (a, stack), b) = Continue (false, prog, stack, CApp (a,b)) |
170 | weak_reduce (true, prog, s as (SAppL (b, stack)), a) = Continue (false, prog, SAppR (a, stack), b) |
170 | weak_reduce (true, prog, SAppL (b, stack), a) = Continue (false, prog, SAppR (a, stack), b) |
171 | weak_reduce (true, prog, stack, c) = Stop (stack, c) |
171 | weak_reduce (true, prog, stack, c) = Stop (stack, c) |
172 |
172 |
173 and strong_reduce (false, prog, stack, Closure (e, CAbs m)) = |
173 and strong_reduce (false, prog, stack, Closure (e, CAbs m)) = |
174 (let |
174 (let |
175 val (stack', wnf) = do_reduction weak_reduce (false, prog, SEmpty, Closure (CDummy::e, m)) |
175 val (stack', wnf) = do_reduction weak_reduce (false, prog, SEmpty, Closure (CDummy::e, m)) |
176 in |
176 in |
177 case stack' of |
177 case stack' of |
178 SEmpty => Continue (false, prog, SAbs stack, wnf) |
178 SEmpty => Continue (false, prog, SAbs stack, wnf) |
179 | _ => raise (Run "internal error in strong: weak failed") |
179 | _ => raise (Run "internal error in strong: weak failed") |
180 end handle InterruptedExecution state => raise InterruptedExecution (stack, resolve state)) |
180 end handle InterruptedExecution state => raise InterruptedExecution (stack, resolve state)) |
181 | strong_reduce (false, prog, stack, clos as (CApp (u, v))) = Continue (false, prog, SAppL (v, stack), u) |
181 | strong_reduce (false, prog, stack, CApp (u, v)) = Continue (false, prog, SAppL (v, stack), u) |
182 | strong_reduce (false, prog, stack, clos) = Continue (true, prog, stack, clos) |
182 | strong_reduce (false, prog, stack, clos) = Continue (true, prog, stack, clos) |
183 | strong_reduce (true, prog, SAbs stack, m) = Continue (false, prog, stack, CAbs m) |
183 | strong_reduce (true, prog, SAbs stack, m) = Continue (false, prog, stack, CAbs m) |
184 | strong_reduce (true, prog, SAppL (b, stack), a) = Continue (false, prog, SAppR (a, stack), b) |
184 | strong_reduce (true, prog, SAppL (b, stack), a) = Continue (false, prog, SAppR (a, stack), b) |
185 | strong_reduce (true, prog, SAppR (a, stack), b) = Continue (true, prog, stack, CApp (a, b)) |
185 | strong_reduce (true, prog, SAppR (a, stack), b) = Continue (true, prog, stack, CApp (a, b)) |
186 | strong_reduce (true, prog, stack, clos) = Stop (stack, clos) |
186 | strong_reduce (true, prog, stack, clos) = Stop (stack, clos) |