216 | taken (_ , bs) = bs; |
216 | taken (_ , bs) = bs; |
217 in |
217 in |
218 taken (t, []) |
218 taken (t, []) |
219 end; |
219 end; |
220 |
220 |
221 (* builds a monadic term for matching a constructor pattern *) |
221 (* builds a monadic term for matching a pattern *) |
222 fun compile_pat match_name pat rhs vs taken = |
222 (* returns (rhs, free variable, used varnames) *) |
223 case pat of |
223 fun compile_pat match_name pat rhs taken = |
224 Const(@{const_name Rep_CFun},_)$f$(v as Free(n,T)) => |
224 let |
225 compile_pat match_name f rhs (v::vs) taken |
225 fun comp_pat p rhs taken = |
226 | Const(@{const_name Rep_CFun},_)$f$x => |
226 if is_Free p then (rhs, p, taken) |
227 let val (rhs', v, taken') = compile_pat match_name x rhs [] taken; |
227 else comp_con (fastype_of p) p rhs [] taken |
228 in compile_pat match_name f rhs' (v::vs) taken' end |
228 (* compiles a monadic term for a constructor pattern *) |
229 | f$(v as Free(n,T)) => |
229 and comp_con T p rhs vs taken = |
230 compile_pat match_name f rhs (v::vs) taken |
230 case p of |
231 | f$x => |
231 Const(@{const_name Rep_CFun},_) $ f $ x => |
232 let val (rhs', v, taken') = compile_pat match_name x rhs [] taken; |
232 let val (rhs', v, taken') = comp_pat x rhs taken |
233 in compile_pat match_name f rhs' (v::vs) taken' end |
233 in comp_con T f rhs' (v::vs) taken' end |
234 | Const(c,T) => |
234 | f $ x => |
235 let |
235 let val (rhs', v, taken') = comp_pat x rhs taken |
236 val n = Name.variant taken "v"; |
236 in comp_con T f rhs' (v::vs) taken' end |
237 fun result_type (Type(@{type_name cfun},[_,T])) (x::xs) = result_type T xs |
237 | Const (c, cT) => |
238 | result_type (Type (@{type_name "fun"},[_,T])) (x::xs) = result_type T xs |
238 let |
239 | result_type T _ = T; |
239 val n = Name.variant taken "v" |
240 val v = Free(n, result_type T vs); |
240 val v = Free(n, T) |
241 val m = Const(match_name c, matcherT (T, fastype_of rhs)); |
241 val m = Const(match_name c, matcherT (cT, fastype_of rhs)) |
242 val k = big_lambdas vs rhs; |
242 val k = big_lambdas vs rhs |
243 in |
243 in |
244 (m`v`k, v, n::taken) |
244 (m`v`k, v, n::taken) |
245 end |
245 end |
246 | Free(n,_) => fixrec_err ("expected constructor, found free variable " ^ quote n) |
246 | _ => raise TERM ("fixrec: invalid pattern ", [p]) |
247 | _ => fixrec_err "compile_pat: invalid pattern"; |
247 in |
|
248 comp_pat pat rhs taken |
|
249 end; |
248 |
250 |
249 (* builds a monadic term for matching a function definition pattern *) |
251 (* builds a monadic term for matching a function definition pattern *) |
250 (* returns (name, arity, matcher) *) |
252 (* returns (name, arity, matcher) *) |
251 fun compile_lhs match_name pat rhs vs taken = |
253 fun compile_lhs match_name pat rhs vs taken = |
252 case pat of |
254 case pat of |
253 Const(@{const_name Rep_CFun}, _)$f$(v as Free(n,T)) => |
255 Const(@{const_name Rep_CFun}, _) $ f $ x => |
254 compile_lhs match_name f rhs (v::vs) taken |
256 let val (rhs', v, taken') = compile_pat match_name x rhs taken; |
255 | Const(@{const_name Rep_CFun}, _)$f$x => |
|
256 let val (rhs', v, taken') = compile_pat match_name x rhs [] taken; |
|
257 in compile_lhs match_name f rhs' (v::vs) taken' end |
257 in compile_lhs match_name f rhs' (v::vs) taken' end |
258 | Free(_,_) => ((pat, length vs), big_lambdas vs rhs) |
258 | Free(_,_) => ((pat, length vs), big_lambdas vs rhs) |
259 | Const(_,_) => ((pat, length vs), big_lambdas vs rhs) |
259 | Const(_,_) => ((pat, length vs), big_lambdas vs rhs) |
260 | _ => fixrec_err ("function is not declared as constant in theory: " |
260 | _ => fixrec_err ("function is not declared as constant in theory: " |
261 ^ ML_Syntax.print_term pat); |
261 ^ ML_Syntax.print_term pat); |