205 val Envir.Envir {maxidx, tenv, tyenv} = env; |
212 val Envir.Envir {maxidx, tenv, tyenv} = env; |
206 val (tyenv', maxidx') = Sign.typ_unify thy (U, T) (tyenv, maxidx); |
213 val (tyenv', maxidx') = Sign.typ_unify thy (U, T) (tyenv, maxidx); |
207 in Envir.Envir {maxidx = maxidx', tenv = tenv, tyenv = tyenv'} end |
214 in Envir.Envir {maxidx = maxidx', tenv = tenv, tyenv = tyenv'} end |
208 handle Type.TUNIFY => raise CANTUNIFY; |
215 handle Type.TUNIFY => raise CANTUNIFY; |
209 |
216 |
210 fun test_unify_types thy (args as (T,U,_)) = |
217 fun test_unify_types thy (args as (T, U, _)) = |
211 let val str_of = Syntax.string_of_typ_global thy; |
218 let |
212 fun warn() = tracing ("Potential loss of completeness: " ^ str_of U ^ " = " ^ str_of T); |
219 val str_of = Syntax.string_of_typ_global thy; |
213 val env' = unify_types thy args |
220 fun warn () = tracing ("Potential loss of completeness: " ^ str_of U ^ " = " ^ str_of T); |
214 in if is_TVar(T) orelse is_TVar(U) then warn() else (); |
221 val env' = unify_types thy args; |
215 env' |
222 in if is_TVar T orelse is_TVar U then warn () else (); env' end; |
216 end; |
|
217 |
223 |
218 (*Is the term eta-convertible to a single variable with the given rbinder? |
224 (*Is the term eta-convertible to a single variable with the given rbinder? |
219 Examples: ?a ?f(B.0) ?g(B.1,B.0) |
225 Examples: ?a ?f(B.0) ?g(B.1,B.0) |
220 Result is var a for use in SIMPL. *) |
226 Result is var a for use in SIMPL. *) |
221 fun get_eta_var ([], _, Var vT) = vT |
227 fun get_eta_var ([], _, Var vT) = vT |
222 | get_eta_var (_::rbinder, n, f $ Bound i) = |
228 | get_eta_var (_::rbinder, n, f $ Bound i) = |
223 if n=i then get_eta_var (rbinder, n+1, f) |
229 if n = i then get_eta_var (rbinder, n + 1, f) |
224 else raise ASSIGN |
230 else raise ASSIGN |
225 | get_eta_var _ = raise ASSIGN; |
231 | get_eta_var _ = raise ASSIGN; |
226 |
232 |
227 |
233 |
228 (*Solve v=u by assignment -- "fixedpoint" to Huet -- if v not in u. |
234 (*Solve v=u by assignment -- "fixedpoint" to Huet -- if v not in u. |
229 If v occurs rigidly then nonunifiable. |
235 If v occurs rigidly then nonunifiable. |
230 If v occurs nonrigidly then must use full algorithm. *) |
236 If v occurs nonrigidly then must use full algorithm. *) |
231 fun assignment thy (env, rbinder, t, u) = |
237 fun assignment thy (env, rbinder, t, u) = |
232 let val vT as (v,T) = get_eta_var (rbinder, 0, t) |
238 let val vT as (v,T) = get_eta_var (rbinder, 0, t) in |
233 in case rigid_occurs_term (Unsynchronized.ref [], env, v, u) of |
239 (case rigid_occurs_term (Unsynchronized.ref [], env, v, u) of |
234 NoOcc => let val env = unify_types thy (body_type env T, |
240 NoOcc => |
235 fastype env (rbinder,u),env) |
241 let val env = unify_types thy (body_type env T, fastype env (rbinder, u), env) |
236 in Envir.update ((vT, Logic.rlist_abs (rbinder, u)), env) end |
242 in Envir.update ((vT, Logic.rlist_abs (rbinder, u)), env) end |
237 | Nonrigid => raise ASSIGN |
243 | Nonrigid => raise ASSIGN |
238 | Rigid => raise CANTUNIFY |
244 | Rigid => raise CANTUNIFY) |
239 end; |
245 end; |
240 |
246 |
241 |
247 |
242 (*Extends an rbinder with a new disagreement pair, if both are abstractions. |
248 (*Extends an rbinder with a new disagreement pair, if both are abstractions. |
243 Tries to unify types of the bound variables! |
249 Tries to unify types of the bound variables! |
244 Checks that binders have same length, since terms should be eta-normal; |
250 Checks that binders have same length, since terms should be eta-normal; |
245 if not, raises TERM, probably indicating type mismatch. |
251 if not, raises TERM, probably indicating type mismatch. |
246 Uses variable a (unless the null string) to preserve user's naming.*) |
252 Uses variable a (unless the null string) to preserve user's naming.*) |
247 fun new_dpair thy (rbinder, Abs(a,T,body1), Abs(b,U,body2), env) = |
253 fun new_dpair thy (rbinder, Abs (a, T, body1), Abs (b, U, body2), env) = |
248 let val env' = unify_types thy (T,U,env) |
254 let |
249 val c = if a="" then b else a |
255 val env' = unify_types thy (T, U, env); |
250 in new_dpair thy ((c,T) :: rbinder, body1, body2, env') end |
256 val c = if a = "" then b else a; |
251 | new_dpair _ (_, Abs _, _, _) = raise TERM ("new_dpair", []) |
257 in new_dpair thy ((c,T) :: rbinder, body1, body2, env') end |
252 | new_dpair _ (_, _, Abs _, _) = raise TERM ("new_dpair", []) |
258 | new_dpair _ (_, Abs _, _, _) = raise TERM ("new_dpair", []) |
253 | new_dpair _ (rbinder, t1, t2, env) = ((rbinder, t1, t2), env); |
259 | new_dpair _ (_, _, Abs _, _) = raise TERM ("new_dpair", []) |
254 |
260 | new_dpair _ (rbinder, t1, t2, env) = ((rbinder, t1, t2), env); |
255 |
261 |
256 fun head_norm_dpair thy (env, (rbinder,t,u)) : dpair * Envir.env = |
262 |
257 new_dpair thy (rbinder, |
263 fun head_norm_dpair thy (env, (rbinder, t, u)) : dpair * Envir.env = |
|
264 new_dpair thy (rbinder, |
258 eta_norm env (rbinder, Envir.head_norm env t), |
265 eta_norm env (rbinder, Envir.head_norm env t), |
259 eta_norm env (rbinder, Envir.head_norm env u), env); |
266 eta_norm env (rbinder, Envir.head_norm env u), env); |
260 |
267 |
261 |
268 |
262 |
269 |
263 (*flexflex: the flex-flex pairs, flexrigid: the flex-rigid pairs |
270 (*flexflex: the flex-flex pairs, flexrigid: the flex-rigid pairs |
264 Does not perform assignments for flex-flex pairs: |
271 Does not perform assignments for flex-flex pairs: |
265 may create nonrigid paths, which prevent other assignments. |
272 may create nonrigid paths, which prevent other assignments. |
266 Does not even identify Vars in dpairs such as ?a =?= ?b; an attempt to |
273 Does not even identify Vars in dpairs such as ?a =?= ?b; an attempt to |
267 do so caused numerous problems with no compensating advantage. |
274 do so caused numerous problems with no compensating advantage. |
268 *) |
275 *) |
269 fun SIMPL0 thy (dp0, (env,flexflex,flexrigid)) |
276 fun SIMPL0 thy (dp0, (env,flexflex,flexrigid)) : Envir.env * dpair list * dpair list = |
270 : Envir.env * dpair list * dpair list = |
277 let |
271 let val (dp as (rbinder,t,u), env) = head_norm_dpair thy (env,dp0); |
278 val (dp as (rbinder, t, u), env) = head_norm_dpair thy (env, dp0); |
272 fun SIMRANDS(f$t, g$u, env) = |
279 fun SIMRANDS (f $ t, g $ u, env) = |
273 SIMPL0 thy ((rbinder,t,u), SIMRANDS(f,g,env)) |
280 SIMPL0 thy ((rbinder, t, u), SIMRANDS (f, g, env)) |
274 | SIMRANDS (t as _$_, _, _) = |
281 | SIMRANDS (t as _$_, _, _) = |
275 raise TERM ("SIMPL: operands mismatch", [t,u]) |
282 raise TERM ("SIMPL: operands mismatch", [t, u]) |
276 | SIMRANDS (t, u as _$_, _) = |
283 | SIMRANDS (t, u as _ $ _, _) = |
277 raise TERM ("SIMPL: operands mismatch", [t,u]) |
284 raise TERM ("SIMPL: operands mismatch", [t, u]) |
278 | SIMRANDS(_,_,env) = (env,flexflex,flexrigid); |
285 | SIMRANDS (_, _, env) = (env, flexflex, flexrigid); |
279 in case (head_of t, head_of u) of |
286 in |
280 (Var(_,T), Var(_,U)) => |
287 (case (head_of t, head_of u) of |
281 let val T' = body_type env T and U' = body_type env U; |
288 (Var (_, T), Var (_, U)) => |
282 val env = unify_types thy (T',U',env) |
289 let |
283 in (env, dp::flexflex, flexrigid) end |
290 val T' = body_type env T and U' = body_type env U; |
284 | (Var _, _) => |
291 val env = unify_types thy (T', U', env); |
285 ((assignment thy (env,rbinder,t,u), flexflex, flexrigid) |
292 in (env, dp :: flexflex, flexrigid) end |
286 handle ASSIGN => (env, flexflex, dp::flexrigid)) |
293 | (Var _, _) => |
287 | (_, Var _) => |
294 ((assignment thy (env, rbinder,t,u), flexflex, flexrigid) |
288 ((assignment thy (env,rbinder,u,t), flexflex, flexrigid) |
295 handle ASSIGN => (env, flexflex, dp :: flexrigid)) |
289 handle ASSIGN => (env, flexflex, (rbinder,u,t)::flexrigid)) |
296 | (_, Var _) => |
290 | (Const(a,T), Const(b,U)) => |
297 ((assignment thy (env, rbinder, u, t), flexflex, flexrigid) |
291 if a=b then SIMRANDS(t,u, unify_types thy (T,U,env)) |
298 handle ASSIGN => (env, flexflex, (rbinder, u, t) :: flexrigid)) |
292 else raise CANTUNIFY |
299 | (Const (a, T), Const (b, U)) => |
293 | (Bound i, Bound j) => |
300 if a = b then SIMRANDS (t, u, unify_types thy (T, U, env)) |
294 if i=j then SIMRANDS(t,u,env) else raise CANTUNIFY |
301 else raise CANTUNIFY |
295 | (Free(a,T), Free(b,U)) => |
302 | (Bound i, Bound j) => |
296 if a=b then SIMRANDS(t,u, unify_types thy (T,U,env)) |
303 if i = j then SIMRANDS (t, u, env) else raise CANTUNIFY |
297 else raise CANTUNIFY |
304 | (Free (a, T), Free (b, U)) => |
298 | _ => raise CANTUNIFY |
305 if a = b then SIMRANDS (t, u, unify_types thy (T, U, env)) |
299 end; |
306 else raise CANTUNIFY |
|
307 | _ => raise CANTUNIFY) |
|
308 end; |
300 |
309 |
301 |
310 |
302 (* changed(env,t) checks whether the head of t is a variable assigned in env*) |
311 (* changed(env,t) checks whether the head of t is a variable assigned in env*) |
303 fun changed (env, f$_) = changed (env,f) |
312 fun changed (env, f $ _) = changed (env, f) |
304 | changed (env, Var v) = |
313 | changed (env, Var v) = (case Envir.lookup (env, v) of NONE => false | _ => true) |
305 (case Envir.lookup(env,v) of NONE=>false | _ => true) |
|
306 | changed _ = false; |
314 | changed _ = false; |
307 |
315 |
308 |
316 |
309 (*Recursion needed if any of the 'head variables' have been updated |
317 (*Recursion needed if any of the 'head variables' have been updated |
310 Clever would be to re-do just the affected dpairs*) |
318 Clever would be to re-do just the affected dpairs*) |
311 fun SIMPL thy (env,dpairs) : Envir.env * dpair list * dpair list = |
319 fun SIMPL thy (env,dpairs) : Envir.env * dpair list * dpair list = |
312 let val all as (env',flexflex,flexrigid) = |
320 let |
313 List.foldr (SIMPL0 thy) (env,[],[]) dpairs; |
321 val all as (env', flexflex, flexrigid) = List.foldr (SIMPL0 thy) (env, [], []) dpairs; |
314 val dps = flexrigid@flexflex |
322 val dps = flexrigid @ flexflex; |
315 in if exists (fn ((_,t,u)) => changed(env',t) orelse changed(env',u)) dps |
323 in |
316 then SIMPL thy (env',dps) else all |
324 if exists (fn (_, t, u) => changed (env', t) orelse changed (env', u)) dps |
317 end; |
325 then SIMPL thy (env', dps) else all |
|
326 end; |
318 |
327 |
319 |
328 |
320 (*Makes the terms E1,...,Em, where Ts = [T...Tm]. |
329 (*Makes the terms E1,...,Em, where Ts = [T...Tm]. |
321 Each Ei is ?Gi(B.(n-1),...,B.0), and has type Ti |
330 Each Ei is ?Gi(B.(n-1),...,B.0), and has type Ti |
322 The B.j are bound vars of binder. |
331 The B.j are bound vars of binder. |
323 The terms are not made in eta-normal-form, SIMPL does that later. |
332 The terms are not made in eta-normal-form, SIMPL does that later. |
324 If done here, eta-expansion must be recursive in the arguments! *) |
333 If done here, eta-expansion must be recursive in the arguments! *) |
325 fun make_args name (binder: typ list, env, []) = (env, []) (*frequent case*) |
334 fun make_args name (binder: typ list, env, []) = (env, []) (*frequent case*) |
326 | make_args name (binder: typ list, env, Ts) : Envir.env * term list = |
335 | make_args name (binder: typ list, env, Ts) : Envir.env * term list = |
327 let fun funtype T = binder--->T; |
336 let |
328 val (env', vars) = Envir.genvars name (env, map funtype Ts) |
337 fun funtype T = binder ---> T; |
329 in (env', map (fn var=> Logic.combound(var, 0, length binder)) vars) end; |
338 val (env', vars) = Envir.genvars name (env, map funtype Ts); |
|
339 in (env', map (fn var => Logic.combound (var, 0, length binder)) vars) end; |
330 |
340 |
331 |
341 |
332 (*Abstraction over a list of types, like list_abs*) |
342 (*Abstraction over a list of types, like list_abs*) |
333 fun types_abs ([],u) = u |
343 fun types_abs ([], u) = u |
334 | types_abs (T::Ts, u) = Abs("", T, types_abs(Ts,u)); |
344 | types_abs (T :: Ts, u) = Abs ("", T, types_abs (Ts, u)); |
335 |
345 |
336 (*Abstraction over the binder of a type*) |
346 (*Abstraction over the binder of a type*) |
337 fun type_abs (env,T,t) = types_abs(binder_types env T, t); |
347 fun type_abs (env, T, t) = types_abs (binder_types env T, t); |
338 |
348 |
339 |
349 |
340 (*MATCH taking "big steps". |
350 (*MATCH taking "big steps". |
341 Copies u into the Var v, using projection on targs or imitation. |
351 Copies u into the Var v, using projection on targs or imitation. |
342 A projection is allowed unless SIMPL raises an exception. |
352 A projection is allowed unless SIMPL raises an exception. |
344 or if u is a variable (flex-flex dpair). |
354 or if u is a variable (flex-flex dpair). |
345 Returns long sequence of every way of copying u, for backtracking |
355 Returns long sequence of every way of copying u, for backtracking |
346 For example, projection in ?b'(?a) may be wrong if other dpairs constrain ?a. |
356 For example, projection in ?b'(?a) may be wrong if other dpairs constrain ?a. |
347 The order for trying projections is crucial in ?b'(?a) |
357 The order for trying projections is crucial in ?b'(?a) |
348 NB "vname" is only used in the call to make_args!! *) |
358 NB "vname" is only used in the call to make_args!! *) |
349 fun matchcopy thy vname = let fun mc(rbinder, targs, u, ed as (env,dpairs)) |
359 fun matchcopy thy vname = |
350 : (term * (Envir.env * dpair list))Seq.seq = |
360 let |
351 let |
361 fun mc (rbinder, targs, u, ed as (env, dpairs)) : (term * (Envir.env * dpair list)) Seq.seq = |
352 val trace_tps = Config.get_global thy trace_types; |
362 let |
353 (*Produce copies of uarg and cons them in front of uargs*) |
363 val trace_tps = Config.get_global thy trace_types; |
354 fun copycons uarg (uargs, (env, dpairs)) = |
364 (*Produce copies of uarg and cons them in front of uargs*) |
355 Seq.map(fn (uarg', ed') => (uarg'::uargs, ed')) |
365 fun copycons uarg (uargs, (env, dpairs)) = |
356 (mc (rbinder, targs,eta_norm env (rbinder, Envir.head_norm env uarg), |
366 Seq.map (fn (uarg', ed') => (uarg' :: uargs, ed')) |
357 (env, dpairs))); |
367 (mc (rbinder, targs,eta_norm env (rbinder, Envir.head_norm env uarg), |
358 (*Produce sequence of all possible ways of copying the arg list*) |
368 (env, dpairs))); |
359 fun copyargs [] = Seq.cons ([],ed) Seq.empty |
369 (*Produce sequence of all possible ways of copying the arg list*) |
360 | copyargs (uarg::uargs) = Seq.maps (copycons uarg) (copyargs uargs); |
370 fun copyargs [] = Seq.cons ([], ed) Seq.empty |
361 val (uhead,uargs) = strip_comb u; |
371 | copyargs (uarg :: uargs) = Seq.maps (copycons uarg) (copyargs uargs); |
362 val base = body_type env (fastype env (rbinder,uhead)); |
372 val (uhead, uargs) = strip_comb u; |
363 fun joinargs (uargs',ed') = (list_comb(uhead,uargs'), ed'); |
373 val base = body_type env (fastype env (rbinder, uhead)); |
364 (*attempt projection on argument with given typ*) |
374 fun joinargs (uargs', ed') = (list_comb (uhead, uargs'), ed'); |
365 val Ts = map (curry (fastype env) rbinder) targs; |
375 (*attempt projection on argument with given typ*) |
366 fun projenv (head, (Us,bary), targ, tail) = |
376 val Ts = map (curry (fastype env) rbinder) targs; |
367 let val env = if trace_tps then test_unify_types thy (base,bary,env) |
377 fun projenv (head, (Us, bary), targ, tail) = |
368 else unify_types thy (base,bary,env) |
378 let |
369 in Seq.make (fn () => |
379 val env = |
370 let val (env',args) = make_args vname (Ts,env,Us); |
380 if trace_tps then test_unify_types thy (base, bary, env) |
371 (*higher-order projection: plug in targs for bound vars*) |
381 else unify_types thy (base, bary, env) |
372 fun plugin arg = list_comb(head_of arg, targs); |
382 in |
373 val dp = (rbinder, list_comb(targ, map plugin args), u); |
383 Seq.make (fn () => |
374 val (env2,frigid,fflex) = SIMPL thy (env', dp::dpairs) |
384 let |
375 (*may raise exception CANTUNIFY*) |
385 val (env', args) = make_args vname (Ts, env, Us); |
376 in SOME ((list_comb(head,args), (env2, frigid@fflex)), |
386 (*higher-order projection: plug in targs for bound vars*) |
377 tail) |
387 fun plugin arg = list_comb (head_of arg, targs); |
378 end handle CANTUNIFY => Seq.pull tail) |
388 val dp = (rbinder, list_comb (targ, map plugin args), u); |
379 end handle CANTUNIFY => tail; |
389 val (env2, frigid, fflex) = SIMPL thy (env', dp :: dpairs); |
380 (*make a list of projections*) |
390 (*may raise exception CANTUNIFY*) |
381 fun make_projs (T::Ts, targ::targs) = |
391 in |
382 (Bound(length Ts), T, targ) :: make_projs (Ts,targs) |
392 SOME ((list_comb (head, args), (env2, frigid @ fflex)), tail) |
383 | make_projs ([],[]) = [] |
393 end handle CANTUNIFY => Seq.pull tail) |
384 | make_projs _ = raise TERM ("make_projs", u::targs); |
394 end handle CANTUNIFY => tail; |
385 (*try projections and imitation*) |
395 (*make a list of projections*) |
386 fun matchfun ((bvar,T,targ)::projs) = |
396 fun make_projs (T::Ts, targ::targs) = |
387 (projenv(bvar, strip_type env T, targ, matchfun projs)) |
397 (Bound(length Ts), T, targ) :: make_projs (Ts,targs) |
388 | matchfun [] = (*imitation last of all*) |
398 | make_projs ([],[]) = [] |
389 (case uhead of |
399 | make_projs _ = raise TERM ("make_projs", u::targs); |
390 Const _ => Seq.map joinargs (copyargs uargs) |
400 (*try projections and imitation*) |
391 | Free _ => Seq.map joinargs (copyargs uargs) |
401 fun matchfun ((bvar,T,targ)::projs) = |
392 | _ => Seq.empty) (*if Var, would be a loop!*) |
402 (projenv(bvar, strip_type env T, targ, matchfun projs)) |
393 in case uhead of |
403 | matchfun [] = (*imitation last of all*) |
394 Abs(a, T, body) => |
404 (case uhead of |
395 Seq.map(fn (body', ed') => (Abs (a,T,body'), ed')) |
405 Const _ => Seq.map joinargs (copyargs uargs) |
396 (mc ((a,T)::rbinder, |
406 | Free _ => Seq.map joinargs (copyargs uargs) |
397 (map (incr_boundvars 1) targs) @ [Bound 0], body, ed)) |
407 | _ => Seq.empty) (*if Var, would be a loop!*) |
398 | Var (w,uary) => |
408 in |
399 (*a flex-flex dpair: make variable for t*) |
409 (case uhead of |
400 let val (env', newhd) = Envir.genvar (#1 w) (env, Ts---> base) |
410 Abs (a, T, body) => |
401 val tabs = Logic.combound(newhd, 0, length Ts) |
411 Seq.map (fn (body', ed') => (Abs (a, T, body'), ed')) |
402 val tsub = list_comb(newhd,targs) |
412 (mc ((a, T) :: rbinder, (map (incr_boundvars 1) targs) @ [Bound 0], body, ed)) |
403 in Seq.single (tabs, (env', (rbinder,tsub,u):: dpairs)) |
413 | Var (w, uary) => |
404 end |
414 (*a flex-flex dpair: make variable for t*) |
405 | _ => matchfun(rev(make_projs(Ts, targs))) |
415 let |
406 end |
416 val (env', newhd) = Envir.genvar (#1 w) (env, Ts ---> base); |
407 in mc end; |
417 val tabs = Logic.combound (newhd, 0, length Ts); |
|
418 val tsub = list_comb (newhd, targs); |
|
419 in Seq.single (tabs, (env', (rbinder, tsub, u) :: dpairs)) end |
|
420 | _ => matchfun (rev (make_projs (Ts, targs)))) |
|
421 end; |
|
422 in mc end; |
408 |
423 |
409 |
424 |
410 (*Call matchcopy to produce assignments to the variable in the dpair*) |
425 (*Call matchcopy to produce assignments to the variable in the dpair*) |
411 fun MATCH thy (env, (rbinder,t,u), dpairs) |
426 fun MATCH thy (env, (rbinder, t, u), dpairs) : (Envir.env * dpair list) Seq.seq = |
412 : (Envir.env * dpair list)Seq.seq = |
427 let |
413 let val (Var (vT as (v, T)), targs) = strip_comb t; |
428 val (Var (vT as (v, T)), targs) = strip_comb t; |
414 val Ts = binder_types env T; |
429 val Ts = binder_types env T; |
415 fun new_dset (u', (env',dpairs')) = |
430 fun new_dset (u', (env', dpairs')) = |
416 (*if v was updated to s, must unify s with u' *) |
431 (*if v was updated to s, must unify s with u' *) |
417 case Envir.lookup (env', vT) of |
432 (case Envir.lookup (env', vT) of |
418 NONE => (Envir.update ((vT, types_abs(Ts, u')), env'), dpairs') |
433 NONE => (Envir.update ((vT, types_abs (Ts, u')), env'), dpairs') |
419 | SOME s => (env', ([], s, types_abs(Ts, u'))::dpairs') |
434 | SOME s => (env', ([], s, types_abs (Ts, u')) :: dpairs')); |
420 in Seq.map new_dset |
435 in |
421 (matchcopy thy (#1 v) (rbinder, targs, u, (env,dpairs))) |
436 Seq.map new_dset (matchcopy thy (#1 v) (rbinder, targs, u, (env, dpairs))) |
422 end; |
437 end; |
423 |
438 |
424 |
439 |
425 |
440 |
426 (**** Flex-flex processing ****) |
441 (**** Flex-flex processing ****) |
427 |
442 |
428 (*At end of unification, do flex-flex assignments like ?a -> ?f(?b) |
443 (*At end of unification, do flex-flex assignments like ?a -> ?f(?b) |
429 Attempts to update t with u, raising ASSIGN if impossible*) |
444 Attempts to update t with u, raising ASSIGN if impossible*) |
430 fun ff_assign thy (env, rbinder, t, u) : Envir.env = |
445 fun ff_assign thy (env, rbinder, t, u) : Envir.env = |
431 let val vT as (v,T) = get_eta_var(rbinder,0,t) |
446 let val vT as (v, T) = get_eta_var (rbinder, 0, t) in |
432 in if occurs_terms (Unsynchronized.ref [], env, v, [u]) then raise ASSIGN |
447 if occurs_terms (Unsynchronized.ref [], env, v, [u]) then raise ASSIGN |
433 else let val env = unify_types thy (body_type env T, |
448 else |
434 fastype env (rbinder,u), |
449 let val env = unify_types thy (body_type env T, fastype env (rbinder, u), env) |
435 env) |
450 in Envir.vupdate ((vT, Logic.rlist_abs (rbinder, u)), env) end |
436 in Envir.vupdate ((vT, Logic.rlist_abs (rbinder, u)), env) end |
451 end; |
437 end; |
|
438 |
452 |
439 |
453 |
440 (*Flex argument: a term, its type, and the index that refers to it.*) |
454 (*Flex argument: a term, its type, and the index that refers to it.*) |
441 type flarg = {t: term, T: typ, j: int}; |
455 type flarg = {t: term, T: typ, j: int}; |
442 |
|
443 |
456 |
444 (*Form the arguments into records for deletion/sorting.*) |
457 (*Form the arguments into records for deletion/sorting.*) |
445 fun flexargs ([],[],[]) = [] : flarg list |
458 fun flexargs ([], [], []) = [] : flarg list |
446 | flexargs (j::js, t::ts, T::Ts) = {j=j, t=t, T=T} :: flexargs(js,ts,Ts) |
459 | flexargs (j :: js, t :: ts, T :: Ts) = {j = j, t = t, T = T} :: flexargs (js, ts, Ts) |
447 | flexargs _ = error"flexargs"; |
460 | flexargs _ = error "flexargs"; |
448 |
461 |
449 |
462 |
450 (*If an argument contains a banned Bound, then it should be deleted. |
463 (*If an argument contains a banned Bound, then it should be deleted. |
451 But if the only path is flexible, this is difficult; the code gives up! |
464 But if the only path is flexible, this is difficult; the code gives up! |
452 In %x y.?a(x) =?= %x y.?b(?c(y)) should we instantiate ?b or ?c *) |
465 In %x y.?a(x) =?= %x y.?b(?c(y)) should we instantiate ?b or ?c *) |
453 exception CHANGE_FAIL; (*flexible occurrence of banned variable*) |
466 exception CHANGE_FAIL; (*flexible occurrence of banned variable*) |
454 |
467 |
455 |
468 |
456 (*Check whether the 'banned' bound var indices occur rigidly in t*) |
469 (*Check whether the 'banned' bound var indices occur rigidly in t*) |
457 fun rigid_bound (lev, banned) t = |
470 fun rigid_bound (lev, banned) t = |
458 let val (head,args) = strip_comb t |
471 let val (head,args) = strip_comb t in |
459 in |
472 (case head of |
460 case head of |
473 Bound i => |
461 Bound i => member (op =) banned (i-lev) orelse |
474 member (op =) banned (i - lev) orelse exists (rigid_bound (lev, banned)) args |
462 exists (rigid_bound (lev, banned)) args |
475 | Var _ => false (*no rigid occurrences here!*) |
463 | Var _ => false (*no rigid occurrences here!*) |
476 | Abs (_, _, u) => |
464 | Abs (_,_,u) => |
477 rigid_bound (lev + 1, banned) u orelse |
465 rigid_bound(lev+1, banned) u orelse |
478 exists (rigid_bound (lev, banned)) args |
466 exists (rigid_bound (lev, banned)) args |
479 | _ => exists (rigid_bound (lev, banned)) args) |
467 | _ => exists (rigid_bound (lev, banned)) args |
|
468 end; |
480 end; |
469 |
481 |
470 (*Squash down indices at level >=lev to delete the banned from a term.*) |
482 (*Squash down indices at level >=lev to delete the banned from a term.*) |
471 fun change_bnos banned = |
483 fun change_bnos banned = |
472 let fun change lev (Bound i) = |
484 let |
473 if i<lev then Bound i |
485 fun change lev (Bound i) = |
474 else if member (op =) banned (i-lev) |
486 if i < lev then Bound i |
475 then raise CHANGE_FAIL (**flexible occurrence: give up**) |
487 else if member (op =) banned (i - lev) then |
476 else Bound (i - length (filter (fn j => j < i-lev) banned)) |
488 raise CHANGE_FAIL (**flexible occurrence: give up**) |
477 | change lev (Abs (a,T,t)) = Abs (a, T, change(lev+1) t) |
489 else Bound (i - length (filter (fn j => j < i - lev) banned)) |
478 | change lev (t$u) = change lev t $ change lev u |
490 | change lev (Abs (a, T, t)) = Abs (a, T, change(lev + 1) t) |
479 | change lev t = t |
491 | change lev (t $ u) = change lev t $ change lev u |
480 in change 0 end; |
492 | change lev t = t; |
|
493 in change 0 end; |
481 |
494 |
482 (*Change indices, delete the argument if it contains a banned Bound*) |
495 (*Change indices, delete the argument if it contains a banned Bound*) |
483 fun change_arg banned ({j,t,T}, args) : flarg list = |
496 fun change_arg banned ({j, t, T}, args) : flarg list = |
484 if rigid_bound (0, banned) t then args (*delete argument!*) |
497 if rigid_bound (0, banned) t then args (*delete argument!*) |
485 else {j=j, t= change_bnos banned t, T=T} :: args; |
498 else {j = j, t = change_bnos banned t, T = T} :: args; |
486 |
499 |
487 |
500 |
488 (*Sort the arguments to create assignments if possible: |
501 (*Sort the arguments to create assignments if possible: |
489 create eta-terms like ?g(B.1,B.0) *) |
502 create eta-terms like ?g(B.1,B.0) *) |
490 fun arg_less ({t= Bound i1,...}, {t= Bound i2,...}) = (i2<i1) |
503 fun arg_less ({t = Bound i1, ...}, {t = Bound i2, ...}) = (i2 < i1) |
491 | arg_less (_:flarg, _:flarg) = false; |
504 | arg_less (_: flarg, _: flarg) = false; |
492 |
505 |
493 (*Test whether the new term would be eta-equivalent to a variable -- |
506 (*Test whether the new term would be eta-equivalent to a variable -- |
494 if so then there is no point in creating a new variable*) |
507 if so then there is no point in creating a new variable*) |
495 fun decreasing n ([]: flarg list) = (n=0) |
508 fun decreasing n ([]: flarg list) = (n = 0) |
496 | decreasing n ({j,...}::args) = j=n-1 andalso decreasing (n-1) args; |
509 | decreasing n ({j, ...} :: args) = j = n - 1 andalso decreasing (n - 1) args; |
497 |
510 |
498 (*Delete banned indices in the term, simplifying it. |
511 (*Delete banned indices in the term, simplifying it. |
499 Force an assignment, if possible, by sorting the arguments. |
512 Force an assignment, if possible, by sorting the arguments. |
500 Update its head; squash indices in arguments. *) |
513 Update its head; squash indices in arguments. *) |
501 fun clean_term banned (env,t) = |
514 fun clean_term banned (env,t) = |
502 let val (Var(v,T), ts) = strip_comb t |
515 let |
503 val (Ts,U) = strip_type env T |
516 val (Var (v, T), ts) = strip_comb t; |
504 and js = length ts - 1 downto 0 |
517 val (Ts, U) = strip_type env T |
505 val args = sort (make_ord arg_less) |
518 and js = length ts - 1 downto 0; |
506 (List.foldr (change_arg banned) [] (flexargs (js,ts,Ts))) |
519 val args = sort (make_ord arg_less) (List.foldr (change_arg banned) [] (flexargs (js, ts, Ts))) |
507 val ts' = map (#t) args |
520 val ts' = map #t args; |
508 in |
521 in |
509 if decreasing (length Ts) args then (env, (list_comb(Var(v,T), ts'))) |
522 if decreasing (length Ts) args then (env, (list_comb (Var (v, T), ts'))) |
510 else let val (env',v') = Envir.genvar (#1v) (env, map (#T) args ---> U) |
523 else |
511 val body = list_comb(v', map (Bound o #j) args) |
524 let |
512 val env2 = Envir.vupdate ((((v, T), types_abs(Ts, body)), env')) |
525 val (env', v') = Envir.genvar (#1 v) (env, map #T args ---> U); |
513 (*the vupdate affects ts' if they contain v*) |
526 val body = list_comb (v', map (Bound o #j) args); |
514 in |
527 val env2 = Envir.vupdate ((((v, T), types_abs (Ts, body)), env')); |
515 (env2, Envir.norm_term env2 (list_comb(v',ts'))) |
528 (*the vupdate affects ts' if they contain v*) |
516 end |
529 in (env2, Envir.norm_term env2 (list_comb (v', ts'))) end |
517 end; |
530 end; |
518 |
531 |
519 |
532 |
520 (*Add tpair if not trivial or already there. |
533 (*Add tpair if not trivial or already there. |
521 Should check for swapped pairs??*) |
534 Should check for swapped pairs??*) |
522 fun add_tpair (rbinder, (t0,u0), tpairs) : (term*term) list = |
535 fun add_tpair (rbinder, (t0, u0), tpairs) : (term * term) list = |
523 if t0 aconv u0 then tpairs |
536 if t0 aconv u0 then tpairs |
524 else |
537 else |
525 let val t = Logic.rlist_abs(rbinder, t0) and u = Logic.rlist_abs(rbinder, u0); |
538 let |
526 fun same(t',u') = (t aconv t') andalso (u aconv u') |
539 val t = Logic.rlist_abs (rbinder, t0) |
527 in if exists same tpairs then tpairs else (t,u)::tpairs end; |
540 and u = Logic.rlist_abs (rbinder, u0); |
|
541 fun same (t', u') = (t aconv t') andalso (u aconv u') |
|
542 in if exists same tpairs then tpairs else (t, u) :: tpairs end; |
528 |
543 |
529 |
544 |
530 (*Simplify both terms and check for assignments. |
545 (*Simplify both terms and check for assignments. |
531 Bound vars in the binder are "banned" unless used in both t AND u *) |
546 Bound vars in the binder are "banned" unless used in both t AND u *) |
532 fun clean_ffpair thy ((rbinder, t, u), (env,tpairs)) = |
547 fun clean_ffpair thy ((rbinder, t, u), (env, tpairs)) = |
533 let val loot = loose_bnos t and loou = loose_bnos u |
548 let |
534 fun add_index (j, (a,T)) (bnos, newbinder) = |
549 val loot = loose_bnos t and loou = loose_bnos u |
535 if member (op =) loot j andalso member (op =) loou j |
550 fun add_index (j, (a, T)) (bnos, newbinder) = |
536 then (bnos, (a,T)::newbinder) (*needed by both: keep*) |
551 if member (op =) loot j andalso member (op =) loou j |
537 else (j::bnos, newbinder); (*remove*) |
552 then (bnos, (a, T) :: newbinder) (*needed by both: keep*) |
538 val (banned,rbin') = fold_rev add_index |
553 else (j :: bnos, newbinder); (*remove*) |
539 ((0 upto (length rbinder - 1)) ~~ rbinder) ([],[]); |
554 val (banned, rbin') = fold_rev add_index ((0 upto (length rbinder - 1)) ~~ rbinder) ([], []); |
540 val (env', t') = clean_term banned (env, t); |
555 val (env', t') = clean_term banned (env, t); |
541 val (env'',u') = clean_term banned (env',u) |
556 val (env'',u') = clean_term banned (env',u); |
542 in (ff_assign thy (env'', rbin', t', u'), tpairs) |
557 in |
543 handle ASSIGN => (ff_assign thy (env'', rbin', u', t'), tpairs) |
558 (ff_assign thy (env'', rbin', t', u'), tpairs) |
544 handle ASSIGN => (env'', add_tpair(rbin', (t',u'), tpairs)) |
559 handle ASSIGN => |
|
560 (ff_assign thy (env'', rbin', u', t'), tpairs) |
|
561 handle ASSIGN => (env'', add_tpair (rbin', (t', u'), tpairs)) |
545 end |
562 end |
546 handle CHANGE_FAIL => (env, add_tpair(rbinder, (t,u), tpairs)); |
563 handle CHANGE_FAIL => (env, add_tpair (rbinder, (t, u), tpairs)); |
547 |
564 |
548 |
565 |
549 (*IF the flex-flex dpair is an assignment THEN do it ELSE put in tpairs |
566 (*IF the flex-flex dpair is an assignment THEN do it ELSE put in tpairs |
550 eliminates trivial tpairs like t=t, as well as repeated ones |
567 eliminates trivial tpairs like t=t, as well as repeated ones |
551 trivial tpairs can easily escape SIMPL: ?A=t, ?A=?B, ?B=t gives t=t |
568 trivial tpairs can easily escape SIMPL: ?A=t, ?A=?B, ?B=t gives t=t |
552 Resulting tpairs MAY NOT be in normal form: assignments may occur here.*) |
569 Resulting tpairs MAY NOT be in normal form: assignments may occur here.*) |
553 fun add_ffpair thy ((rbinder,t0,u0), (env,tpairs)) |
570 fun add_ffpair thy ((rbinder,t0,u0), (env,tpairs)) : Envir.env * (term * term) list = |
554 : Envir.env * (term*term)list = |
571 let |
555 let val t = Envir.norm_term env t0 and u = Envir.norm_term env u0 |
572 val t = Envir.norm_term env t0 |
556 in case (head_of t, head_of u) of |
573 and u = Envir.norm_term env u0; |
557 (Var(v,T), Var(w,U)) => (*Check for identical variables...*) |
574 in |
558 if Term.eq_ix (v, w) then (*...occur check would falsely return true!*) |
575 (case (head_of t, head_of u) of |
559 if T=U then (env, add_tpair (rbinder, (t,u), tpairs)) |
576 (Var (v, T), Var (w, U)) => (*Check for identical variables...*) |
560 else raise TERM ("add_ffpair: Var name confusion", [t,u]) |
577 if Term.eq_ix (v, w) then (*...occur check would falsely return true!*) |
561 else if Term_Ord.indexname_ord (v, w) = LESS then (*prefer to update the LARGER variable*) |
578 if T = U then (env, add_tpair (rbinder, (t, u), tpairs)) |
562 clean_ffpair thy ((rbinder, u, t), (env,tpairs)) |
579 else raise TERM ("add_ffpair: Var name confusion", [t, u]) |
563 else clean_ffpair thy ((rbinder, t, u), (env,tpairs)) |
580 else if Term_Ord.indexname_ord (v, w) = LESS then (*prefer to update the LARGER variable*) |
564 | _ => raise TERM ("add_ffpair: Vars expected", [t,u]) |
581 clean_ffpair thy ((rbinder, u, t), (env, tpairs)) |
|
582 else clean_ffpair thy ((rbinder, t, u), (env, tpairs)) |
|
583 | _ => raise TERM ("add_ffpair: Vars expected", [t, u])) |
565 end; |
584 end; |
566 |
585 |
567 |
586 |
568 (*Print a tracing message + list of dpairs. |
587 (*Print a tracing message + list of dpairs. |
569 In t==u print u first because it may be rigid or flexible -- |
588 In t==u print u first because it may be rigid or flexible -- |
570 t is always flexible.*) |
589 t is always flexible.*) |
571 fun print_dpairs thy msg (env,dpairs) = |
590 fun print_dpairs thy msg (env, dpairs) = |
572 let fun pdp (rbinder,t,u) = |
591 let |
573 let fun termT t = Syntax.pretty_term_global thy |
592 fun pdp (rbinder, t, u) = |
574 (Envir.norm_term env (Logic.rlist_abs(rbinder,t))) |
593 let |
575 val bsymbs = [termT u, Pretty.str" =?=", Pretty.brk 1, |
594 fun termT t = |
576 termT t]; |
595 Syntax.pretty_term_global thy (Envir.norm_term env (Logic.rlist_abs (rbinder, t))); |
577 in tracing(Pretty.string_of(Pretty.blk(0,bsymbs))) end; |
596 val bsymbs = [termT u, Pretty.str" =?=", Pretty.brk 1, termT t]; |
578 in tracing msg; List.app pdp dpairs end; |
597 in tracing (Pretty.string_of (Pretty.blk (0, bsymbs))) end; |
|
598 in tracing msg; List.app pdp dpairs end; |
579 |
599 |
580 |
600 |
581 (*Unify the dpairs in the environment. |
601 (*Unify the dpairs in the environment. |
582 Returns flex-flex disagreement pairs NOT IN normal form. |
602 Returns flex-flex disagreement pairs NOT IN normal form. |
583 SIMPL may raise exception CANTUNIFY. *) |
603 SIMPL may raise exception CANTUNIFY. *) |
584 fun hounifiers (thy,env, tus : (term*term)list) |
604 fun hounifiers (thy, env, tus : (term * term) list) : (Envir.env * (term * term) list) Seq.seq = |
585 : (Envir.env * (term*term)list)Seq.seq = |
|
586 let |
605 let |
587 val trace_bnd = Config.get_global thy trace_bound; |
606 val trace_bnd = Config.get_global thy trace_bound; |
588 val search_bnd = Config.get_global thy search_bound; |
607 val search_bnd = Config.get_global thy search_bound; |
589 val trace_smp = Config.get_global thy trace_simp; |
608 val trace_smp = Config.get_global thy trace_simp; |
590 fun add_unify tdepth ((env,dpairs), reseq) = |
609 fun add_unify tdepth ((env, dpairs), reseq) = |
591 Seq.make (fn()=> |
610 Seq.make (fn () => |
592 let val (env',flexflex,flexrigid) = |
611 let |
593 (if tdepth> trace_bnd andalso trace_smp |
612 val (env', flexflex, flexrigid) = |
594 then print_dpairs thy "Enter SIMPL" (env,dpairs) else (); |
613 (if tdepth > trace_bnd andalso trace_smp |
595 SIMPL thy (env,dpairs)) |
614 then print_dpairs thy "Enter SIMPL" (env, dpairs) else (); |
596 in case flexrigid of |
615 SIMPL thy (env, dpairs)); |
597 [] => SOME (List.foldr (add_ffpair thy) (env',[]) flexflex, reseq) |
616 in |
598 | dp::frigid' => |
617 (case flexrigid of |
599 if tdepth > search_bnd then |
618 [] => SOME (List.foldr (add_ffpair thy) (env', []) flexflex, reseq) |
600 (warning "Unification bound exceeded"; Seq.pull reseq) |
619 | dp :: frigid' => |
601 else |
620 if tdepth > search_bnd then |
602 (if tdepth > trace_bnd then |
621 (warning "Unification bound exceeded"; Seq.pull reseq) |
603 print_dpairs thy "Enter MATCH" (env',flexrigid@flexflex) |
622 else |
604 else (); |
623 (if tdepth > trace_bnd then |
605 Seq.pull (Seq.it_right (add_unify (tdepth+1)) |
624 print_dpairs thy "Enter MATCH" (env',flexrigid@flexflex) |
606 (MATCH thy (env',dp, frigid'@flexflex), reseq))) |
625 else (); |
607 end |
626 Seq.pull (Seq.it_right |
608 handle CANTUNIFY => |
627 (add_unify (tdepth + 1)) (MATCH thy (env',dp, frigid'@flexflex), reseq)))) |
609 (if tdepth > trace_bnd then tracing"Failure node" else (); |
628 end |
610 Seq.pull reseq)); |
629 handle CANTUNIFY => |
611 val dps = map (fn(t,u)=> ([],t,u)) tus |
630 (if tdepth > trace_bnd then tracing"Failure node" else (); |
|
631 Seq.pull reseq)); |
|
632 val dps = map (fn (t, u) => ([], t, u)) tus; |
612 in add_unify 1 ((env, dps), Seq.empty) end; |
633 in add_unify 1 ((env, dps), Seq.empty) end; |
613 |
634 |
614 fun unifiers (params as (thy, env, tus)) = |
635 fun unifiers (params as (thy, env, tus)) = |
615 Seq.cons (fold (Pattern.unify thy) tus env, []) Seq.empty |
636 Seq.cons (fold (Pattern.unify thy) tus env, []) Seq.empty |
616 handle Pattern.Unif => Seq.empty |
637 handle Pattern.Unif => Seq.empty |
617 | Pattern.Pattern => hounifiers params; |
638 | Pattern.Pattern => hounifiers params; |
618 |
639 |
619 |
640 |
620 (*For smash_flexflex1*) |
641 (*For smash_flexflex1*) |
621 fun var_head_of (env,t) : indexname * typ = |
642 fun var_head_of (env,t) : indexname * typ = |
622 case head_of (strip_abs_body (Envir.norm_term env t)) of |
643 (case head_of (strip_abs_body (Envir.norm_term env t)) of |
623 Var(v,T) => (v,T) |
644 Var (v, T) => (v, T) |
624 | _ => raise CANTUNIFY; (*not flexible, cannot use trivial substitution*) |
645 | _ => raise CANTUNIFY); (*not flexible, cannot use trivial substitution*) |
625 |
646 |
626 |
647 |
627 (*Eliminate a flex-flex pair by the trivial substitution, see Huet (1975) |
648 (*Eliminate a flex-flex pair by the trivial substitution, see Huet (1975) |
628 Unifies ?f(t1...rm) with ?g(u1...un) by ?f -> %x1...xm.?a, ?g -> %x1...xn.?a |
649 Unifies ?f(t1...rm) with ?g(u1...un) by ?f -> %x1...xm.?a, ?g -> %x1...xn.?a |
629 Unfortunately, unifies ?f(t,u) with ?g(t,u) by ?f, ?g -> %(x,y)?a, |
650 Unfortunately, unifies ?f(t,u) with ?g(t,u) by ?f, ?g -> %(x,y)?a, |
630 though just ?g->?f is a more general unifier. |
651 though just ?g->?f is a more general unifier. |
631 Unlike Huet (1975), does not smash together all variables of same type -- |
652 Unlike Huet (1975), does not smash together all variables of same type -- |
632 requires more work yet gives a less general unifier (fewer variables). |
653 requires more work yet gives a less general unifier (fewer variables). |
633 Handles ?f(t1...rm) with ?f(u1...um) to avoid multiple updates. *) |
654 Handles ?f(t1...rm) with ?f(u1...um) to avoid multiple updates. *) |
634 fun smash_flexflex1 ((t,u), env) : Envir.env = |
655 fun smash_flexflex1 ((t,u), env) : Envir.env = |
635 let val vT as (v,T) = var_head_of (env,t) |
656 let |
636 and wU as (w,U) = var_head_of (env,u); |
657 val vT as (v, T) = var_head_of (env, t) |
637 val (env', var) = Envir.genvar (#1v) (env, body_type env T) |
658 and wU as (w, U) = var_head_of (env, u); |
638 val env'' = Envir.vupdate ((wU, type_abs (env', U, var)), env') |
659 val (env', var) = Envir.genvar (#1 v) (env, body_type env T); |
639 in if vT = wU then env'' (*the other update would be identical*) |
660 val env'' = Envir.vupdate ((wU, type_abs (env', U, var)), env'); |
640 else Envir.vupdate ((vT, type_abs (env', T, var)), env'') |
661 in |
|
662 if vT = wU then env'' (*the other update would be identical*) |
|
663 else Envir.vupdate ((vT, type_abs (env', T, var)), env'') |
641 end; |
664 end; |
642 |
665 |
643 |
666 |
644 (*Smash all flex-flexpairs. Should allow selection of pairs by a predicate?*) |
667 (*Smash all flex-flexpairs. Should allow selection of pairs by a predicate?*) |
645 fun smash_flexflex (env,tpairs) : Envir.env = |
668 fun smash_flexflex (env,tpairs) : Envir.env = |
646 List.foldr smash_flexflex1 env tpairs; |
669 List.foldr smash_flexflex1 env tpairs; |
647 |
670 |
648 (*Returns unifiers with no remaining disagreement pairs*) |
671 (*Returns unifiers with no remaining disagreement pairs*) |
649 fun smash_unifiers thy tus env = |
672 fun smash_unifiers thy tus env = |
650 Seq.map smash_flexflex (unifiers(thy,env,tus)); |
673 Seq.map smash_flexflex (unifiers (thy, env, tus)); |
651 |
674 |
652 |
675 |
653 (*Pattern matching*) |
676 (*Pattern matching*) |
654 fun first_order_matchers thy pairs (Envir.Envir {maxidx, tenv, tyenv}) = |
677 fun first_order_matchers thy pairs (Envir.Envir {maxidx, tenv, tyenv}) = |
655 let val (tyenv', tenv') = fold (Pattern.first_order_match thy) pairs (tyenv, tenv) |
678 let val (tyenv', tenv') = fold (Pattern.first_order_match thy) pairs (tyenv, tenv) |