308 |
309 |
309 (*Compute the type of the term, checking that combinations are well-typed |
310 (*Compute the type of the term, checking that combinations are well-typed |
310 Ts = [T0,T1,...] holds types of bound variables 0, 1, ...*) |
311 Ts = [T0,T1,...] holds types of bound variables 0, 1, ...*) |
311 fun type_of1 (Ts, Const (_,T)) = T |
312 fun type_of1 (Ts, Const (_,T)) = T |
312 | type_of1 (Ts, Free (_,T)) = T |
313 | type_of1 (Ts, Free (_,T)) = T |
313 | type_of1 (Ts, Bound i) = (nth_elem (i,Ts) |
314 | type_of1 (Ts, Bound i) = (nth_elem (i,Ts) |
314 handle LIST _ => raise TYPE("type_of: bound variable", [], [Bound i])) |
315 handle LIST _ => raise TYPE("type_of: bound variable", [], [Bound i])) |
315 | type_of1 (Ts, Var (_,T)) = T |
316 | type_of1 (Ts, Var (_,T)) = T |
316 | type_of1 (Ts, Abs (_,T,body)) = T --> type_of1(T::Ts, body) |
317 | type_of1 (Ts, Abs (_,T,body)) = T --> type_of1(T::Ts, body) |
317 | type_of1 (Ts, f$u) = |
318 | type_of1 (Ts, f$u) = |
318 let val U = type_of1(Ts,u) |
319 let val U = type_of1(Ts,u) |
319 and T = type_of1(Ts,f) |
320 and T = type_of1(Ts,f) |
320 in case T of |
321 in case T of |
321 Type("fun",[T1,T2]) => |
322 Type("fun",[T1,T2]) => |
322 if T1=U then T2 else raise TYPE |
323 if T1=U then T2 else raise TYPE |
323 ("type_of: type mismatch in application", [T1,U], [f$u]) |
324 ("type_of: type mismatch in application", [T1,U], [f$u]) |
324 | _ => raise TYPE |
325 | _ => raise TYPE |
325 ("type_of: function type is expected in application", |
326 ("type_of: function type is expected in application", |
326 [T,U], [f$u]) |
327 [T,U], [f$u]) |
327 end; |
328 end; |
328 |
329 |
329 fun type_of t : typ = type_of1 ([],t); |
330 fun type_of t : typ = type_of1 ([],t); |
330 |
331 |
331 (*Determines the type of a term, with minimal checking*) |
332 (*Determines the type of a term, with minimal checking*) |
332 fun fastype_of1 (Ts, f$u) = |
333 fun fastype_of1 (Ts, f$u) = |
333 (case fastype_of1 (Ts,f) of |
334 (case fastype_of1 (Ts,f) of |
334 Type("fun",[_,T]) => T |
335 Type("fun",[_,T]) => T |
335 | _ => raise TERM("fastype_of: expected function type", [f$u])) |
336 | _ => raise TERM("fastype_of: expected function type", [f$u])) |
336 | fastype_of1 (_, Const (_,T)) = T |
337 | fastype_of1 (_, Const (_,T)) = T |
337 | fastype_of1 (_, Free (_,T)) = T |
338 | fastype_of1 (_, Free (_,T)) = T |
338 | fastype_of1 (Ts, Bound i) = (nth_elem(i,Ts) |
339 | fastype_of1 (Ts, Bound i) = (nth_elem(i,Ts) |
339 handle LIST _ => raise TERM("fastype_of: Bound", [Bound i])) |
340 handle LIST _ => raise TERM("fastype_of: Bound", [Bound i])) |
340 | fastype_of1 (_, Var (_,T)) = T |
341 | fastype_of1 (_, Var (_,T)) = T |
341 | fastype_of1 (Ts, Abs (_,T,u)) = T --> fastype_of1 (T::Ts, u); |
342 | fastype_of1 (Ts, Abs (_,T,u)) = T --> fastype_of1 (T::Ts, u); |
342 |
343 |
343 fun fastype_of t : typ = fastype_of1 ([],t); |
344 fun fastype_of t : typ = fastype_of1 ([],t); |
344 |
345 |
345 |
346 |
346 val list_abs = foldr (fn ((x, T), t) => Abs (x, T, t)); |
347 val list_abs = foldr (fn ((x, T), t) => Abs (x, T, t)); |
347 |
348 |
348 (* maps (x1,...,xn)t to t *) |
349 (* maps (x1,...,xn)t to t *) |
349 fun strip_abs_body (Abs(_,_,t)) = strip_abs_body t |
350 fun strip_abs_body (Abs(_,_,t)) = strip_abs_body t |
350 | strip_abs_body u = u; |
351 | strip_abs_body u = u; |
351 |
352 |
352 (* maps (x1,...,xn)t to [x1, ..., xn] *) |
353 (* maps (x1,...,xn)t to [x1, ..., xn] *) |
353 fun strip_abs_vars (Abs(a,T,t)) = (a,T) :: strip_abs_vars t |
354 fun strip_abs_vars (Abs(a,T,t)) = (a,T) :: strip_abs_vars t |
354 | strip_abs_vars u = [] : (string*typ) list; |
355 | strip_abs_vars u = [] : (string*typ) list; |
355 |
356 |
356 |
357 |
357 fun strip_qnt_body qnt = |
358 fun strip_qnt_body qnt = |
358 let fun strip(tm as Const(c,_)$Abs(_,_,t)) = if c=qnt then strip t else tm |
359 let fun strip(tm as Const(c,_)$Abs(_,_,t)) = if c=qnt then strip t else tm |
368 (* maps (f, [t1,...,tn]) to f(t1,...,tn) *) |
369 (* maps (f, [t1,...,tn]) to f(t1,...,tn) *) |
369 val list_comb : term * term list -> term = foldl (op $); |
370 val list_comb : term * term list -> term = foldl (op $); |
370 |
371 |
371 |
372 |
372 (* maps f(t1,...,tn) to (f, [t1,...,tn]) ; naturally tail-recursive*) |
373 (* maps f(t1,...,tn) to (f, [t1,...,tn]) ; naturally tail-recursive*) |
373 fun strip_comb u : term * term list = |
374 fun strip_comb u : term * term list = |
374 let fun stripc (f$t, ts) = stripc (f, t::ts) |
375 let fun stripc (f$t, ts) = stripc (f, t::ts) |
375 | stripc x = x |
376 | stripc x = x |
376 in stripc(u,[]) end; |
377 in stripc(u,[]) end; |
377 |
378 |
378 |
379 |
379 (* maps f(t1,...,tn) to f , which is never a combination *) |
380 (* maps f(t1,...,tn) to f , which is never a combination *) |
380 fun head_of (f$t) = head_of f |
381 fun head_of (f$t) = head_of f |
432 fun equals T = Const("==", T-->T-->propT); |
433 fun equals T = Const("==", T-->T-->propT); |
433 |
434 |
434 fun flexpair T = Const("=?=", T-->T-->propT); |
435 fun flexpair T = Const("=?=", T-->T-->propT); |
435 |
436 |
436 (* maps !!x1...xn. t to t *) |
437 (* maps !!x1...xn. t to t *) |
437 fun strip_all_body (Const("all",_)$Abs(_,_,t)) = strip_all_body t |
438 fun strip_all_body (Const("all",_)$Abs(_,_,t)) = strip_all_body t |
438 | strip_all_body t = t; |
439 | strip_all_body t = t; |
439 |
440 |
440 (* maps !!x1...xn. t to [x1, ..., xn] *) |
441 (* maps !!x1...xn. t to [x1, ..., xn] *) |
441 fun strip_all_vars (Const("all",_)$Abs(a,T,t)) = |
442 fun strip_all_vars (Const("all",_)$Abs(a,T,t)) = |
442 (a,T) :: strip_all_vars t |
443 (a,T) :: strip_all_vars t |
443 | strip_all_vars t = [] : (string*typ) list; |
444 | strip_all_vars t = [] : (string*typ) list; |
444 |
445 |
445 (*increments a term's non-local bound variables |
446 (*increments a term's non-local bound variables |
446 required when moving a term within abstractions |
447 required when moving a term within abstractions |
447 inc is increment for bound variables |
448 inc is increment for bound variables |
448 lev is level at which a bound variable is considered 'loose'*) |
449 lev is level at which a bound variable is considered 'loose'*) |
449 fun incr_bv (inc, lev, u as Bound i) = if i>=lev then Bound(i+inc) else u |
450 fun incr_bv (inc, lev, u as Bound i) = if i>=lev then Bound(i+inc) else u |
450 | incr_bv (inc, lev, Abs(a,T,body)) = |
451 | incr_bv (inc, lev, Abs(a,T,body)) = |
451 Abs(a, T, incr_bv(inc,lev+1,body)) |
452 Abs(a, T, incr_bv(inc,lev+1,body)) |
452 | incr_bv (inc, lev, f$t) = |
453 | incr_bv (inc, lev, f$t) = |
453 incr_bv(inc,lev,f) $ incr_bv(inc,lev,t) |
454 incr_bv(inc,lev,f) $ incr_bv(inc,lev,t) |
454 | incr_bv (inc, lev, u) = u; |
455 | incr_bv (inc, lev, u) = u; |
455 |
456 |
456 fun incr_boundvars 0 t = t |
457 fun incr_boundvars 0 t = t |
457 | incr_boundvars inc t = incr_bv(inc,0,t); |
458 | incr_boundvars inc t = incr_bv(inc,0,t); |
476 | ren_abs t = t |
477 | ren_abs t = t |
477 in if null ren then None else Some (ren_abs t) end; |
478 in if null ren then None else Some (ren_abs t) end; |
478 |
479 |
479 (*Accumulate all 'loose' bound vars referring to level 'lev' or beyond. |
480 (*Accumulate all 'loose' bound vars referring to level 'lev' or beyond. |
480 (Bound 0) is loose at level 0 *) |
481 (Bound 0) is loose at level 0 *) |
481 fun add_loose_bnos (Bound i, lev, js) = |
482 fun add_loose_bnos (Bound i, lev, js) = |
482 if i<lev then js else (i-lev) ins_int js |
483 if i<lev then js else (i-lev) ins_int js |
483 | add_loose_bnos (Abs (_,_,t), lev, js) = add_loose_bnos (t, lev+1, js) |
484 | add_loose_bnos (Abs (_,_,t), lev, js) = add_loose_bnos (t, lev+1, js) |
484 | add_loose_bnos (f$t, lev, js) = |
485 | add_loose_bnos (f$t, lev, js) = |
485 add_loose_bnos (f, lev, add_loose_bnos (t, lev, js)) |
486 add_loose_bnos (f, lev, add_loose_bnos (t, lev, js)) |
486 | add_loose_bnos (_, _, js) = js; |
487 | add_loose_bnos (_, _, js) = js; |
487 |
488 |
488 fun loose_bnos t = add_loose_bnos (t, 0, []); |
489 fun loose_bnos t = add_loose_bnos (t, 0, []); |
489 |
490 |
490 (* loose_bvar(t,k) iff t contains a 'loose' bound variable referring to |
491 (* loose_bvar(t,k) iff t contains a 'loose' bound variable referring to |
516 | subst (f$t, lev) = subst(f,lev) $ subst(t,lev) |
517 | subst (f$t, lev) = subst(f,lev) $ subst(t,lev) |
517 | subst (t,lev) = t |
518 | subst (t,lev) = t |
518 in case args of [] => t | _ => subst (t,0) end; |
519 in case args of [] => t | _ => subst (t,0) end; |
519 |
520 |
520 (*Special case: one argument*) |
521 (*Special case: one argument*) |
521 fun subst_bound (arg, t) : term = |
522 fun subst_bound (arg, t) : term = |
522 let fun subst (t as Bound i, lev) = |
523 let fun subst (t as Bound i, lev) = |
523 if i<lev then t (*var is locally bound*) |
524 if i<lev then t (*var is locally bound*) |
524 else if i=lev then incr_boundvars lev arg |
525 else if i=lev then incr_boundvars lev arg |
525 else Bound(i-1) (*loose: change it*) |
526 else Bound(i-1) (*loose: change it*) |
526 | subst (Abs(a,T,body), lev) = Abs(a, T, subst(body,lev+1)) |
527 | subst (Abs(a,T,body), lev) = Abs(a, T, subst(body,lev+1)) |
652 (*Form an abstraction over a free variable.*) |
653 (*Form an abstraction over a free variable.*) |
653 fun absfree (a,T,body) = Abs(a, T, abstract_over (Free(a,T), body)); |
654 fun absfree (a,T,body) = Abs(a, T, abstract_over (Free(a,T), body)); |
654 |
655 |
655 (*Abstraction over a list of free variables*) |
656 (*Abstraction over a list of free variables*) |
656 fun list_abs_free ([ ] , t) = t |
657 fun list_abs_free ([ ] , t) = t |
657 | list_abs_free ((a,T)::vars, t) = |
658 | list_abs_free ((a,T)::vars, t) = |
658 absfree(a, T, list_abs_free(vars,t)); |
659 absfree(a, T, list_abs_free(vars,t)); |
659 |
660 |
660 (*Quantification over a list of free variables*) |
661 (*Quantification over a list of free variables*) |
661 fun list_all_free ([], t: term) = t |
662 fun list_all_free ([], t: term) = t |
662 | list_all_free ((a,T)::vars, t) = |
663 | list_all_free ((a,T)::vars, t) = |
663 (all T) $ (absfree(a, T, list_all_free(vars,t))); |
664 (all T) $ (absfree(a, T, list_all_free(vars,t))); |
664 |
665 |
665 (*Quantification over a list of variables (already bound in body) *) |
666 (*Quantification over a list of variables (already bound in body) *) |
666 fun list_all ([], t) = t |
667 fun list_all ([], t) = t |
667 | list_all ((a,T)::vars, t) = |
668 | list_all ((a,T)::vars, t) = |
668 (all T) $ (Abs(a, T, list_all(vars,t))); |
669 (all T) $ (Abs(a, T, list_all(vars,t))); |
669 |
670 |
670 (*Replace the ATOMIC term ti by ui; instl = [(t1,u1), ..., (tn,un)]. |
671 (*Replace the ATOMIC term ti by ui; instl = [(t1,u1), ..., (tn,un)]. |
671 A simultaneous substitution: [ (a,b), (b,a) ] swaps a and b. *) |
672 A simultaneous substitution: [ (a,b), (b,a) ] swaps a and b. *) |
672 fun subst_atomic [] t = t : term |
673 fun subst_atomic [] t = t : term |
673 | subst_atomic (instl: (term*term) list) t = |
674 | subst_atomic (instl: (term*term) list) t = |
674 let fun subst (Abs(a,T,body)) = Abs(a, T, subst body) |
675 let fun subst (Abs(a,T,body)) = Abs(a, T, subst body) |
675 | subst (f$t') = subst f $ subst t' |
676 | subst (f$t') = subst f $ subst t' |
874 fun term_tvars t = add_term_tvars(t,[]); |
875 fun term_tvars t = add_term_tvars(t,[]); |
875 |
876 |
876 (*special code to enforce left-to-right collection of TVar-indexnames*) |
877 (*special code to enforce left-to-right collection of TVar-indexnames*) |
877 |
878 |
878 fun add_typ_ixns(ixns,Type(_,Ts)) = foldl add_typ_ixns (ixns,Ts) |
879 fun add_typ_ixns(ixns,Type(_,Ts)) = foldl add_typ_ixns (ixns,Ts) |
879 | add_typ_ixns(ixns,TVar(ixn,_)) = if mem_ix (ixn, ixns) then ixns |
880 | add_typ_ixns(ixns,TVar(ixn,_)) = if mem_ix (ixn, ixns) then ixns |
880 else ixns@[ixn] |
881 else ixns@[ixn] |
881 | add_typ_ixns(ixns,TFree(_)) = ixns; |
882 | add_typ_ixns(ixns,TFree(_)) = ixns; |
882 |
883 |
883 fun add_term_tvar_ixns(Const(_,T),ixns) = add_typ_ixns(ixns,T) |
884 fun add_term_tvar_ixns(Const(_,T),ixns) = add_typ_ixns(ixns,T) |
884 | add_term_tvar_ixns(Free(_,T),ixns) = add_typ_ixns(ixns,T) |
885 | add_term_tvar_ixns(Free(_,T),ixns) = add_typ_ixns(ixns,T) |
979 (** type and term orders **) |
980 (** type and term orders **) |
980 |
981 |
981 fun indexname_ord ((x, i), (y, j)) = |
982 fun indexname_ord ((x, i), (y, j)) = |
982 (case int_ord (i, j) of EQUAL => string_ord (x, y) | ord => ord); |
983 (case int_ord (i, j) of EQUAL => string_ord (x, y) | ord => ord); |
983 |
984 |
|
985 val sort_ord = list_ord string_ord; |
|
986 |
984 |
987 |
985 (* typ_ord *) |
988 (* typ_ord *) |
986 |
989 |
987 (*assumes that TFrees / TVars with the same name have same sorts*) |
990 fun typ_ord (Type x, Type y) = prod_ord string_ord typs_ord (x, y) |
988 fun typ_ord (Type (a, Ts), Type (b, Us)) = |
|
989 (case string_ord (a, b) of EQUAL => typs_ord (Ts, Us) | ord => ord) |
|
990 | typ_ord (Type _, _) = GREATER |
991 | typ_ord (Type _, _) = GREATER |
991 | typ_ord (TFree _, Type _) = LESS |
992 | typ_ord (TFree _, Type _) = LESS |
992 | typ_ord (TFree (a, _), TFree (b, _)) = string_ord (a, b) |
993 | typ_ord (TFree x, TFree y) = prod_ord string_ord sort_ord (x, y) |
993 | typ_ord (TFree _, TVar _) = GREATER |
994 | typ_ord (TFree _, TVar _) = GREATER |
994 | typ_ord (TVar _, Type _) = LESS |
995 | typ_ord (TVar _, Type _) = LESS |
995 | typ_ord (TVar _, TFree _) = LESS |
996 | typ_ord (TVar _, TFree _) = LESS |
996 | typ_ord (TVar (xi, _), TVar (yj, _)) = indexname_ord (xi, yj) |
997 | typ_ord (TVar x, TVar y) = prod_ord indexname_ord sort_ord (x, y) |
997 and typs_ord Ts_Us = list_ord typ_ord Ts_Us; |
998 and typs_ord Ts_Us = list_ord typ_ord Ts_Us; |
998 |
999 |
999 |
1000 |
1000 (* term_ord *) |
1001 (* term_ord *) |
1001 |
1002 |
1039 |
1041 |
1040 (*Substitute for type Vars in a term, version using Vartab*) |
1042 (*Substitute for type Vars in a term, version using Vartab*) |
1041 val subst_TVars_Vartab = map_term_types o typ_subst_TVars_Vartab; |
1043 val subst_TVars_Vartab = map_term_types o typ_subst_TVars_Vartab; |
1042 |
1044 |
1043 |
1045 |
1044 (*** Compression of terms and types by sharing common subtrees. |
1046 (*** Compression of terms and types by sharing common subtrees. |
1045 Saves 50-75% on storage requirements. As it is fairly slow, |
1047 Saves 50-75% on storage requirements. As it is a bit slow, |
1046 it is called only for axioms, stored theorems, etc. ***) |
1048 it should be called only for axioms, stored theorems, etc. |
|
1049 Recorded term and type fragments are never disposed. ***) |
1047 |
1050 |
1048 (** Sharing of types **) |
1051 (** Sharing of types **) |
1049 |
1052 |
1050 fun atomic_tag (Type (a,_)) = if a<>"fun" then a else raise Match |
1053 val memo_types = ref (Typtab.empty: typ Typtab.table); |
1051 | atomic_tag (TFree (a,_)) = a |
|
1052 | atomic_tag (TVar ((a,_),_)) = a; |
|
1053 |
|
1054 fun type_tag (Type("fun",[S,T])) = atomic_tag S ^ type_tag T |
|
1055 | type_tag T = atomic_tag T; |
|
1056 |
|
1057 val memo_types = ref (Symtab.empty : typ list Symtab.table); |
|
1058 |
|
1059 (* special case of library/find_first *) |
|
1060 fun find_type (T, []: typ list) = None |
|
1061 | find_type (T, T'::Ts) = |
|
1062 if T=T' then Some T' |
|
1063 else find_type (T, Ts); |
|
1064 |
1054 |
1065 fun compress_type T = |
1055 fun compress_type T = |
1066 let val tag = type_tag T |
1056 (case Typtab.lookup (! memo_types, T) of |
1067 val tylist = Symtab.lookup_multi (!memo_types, tag) |
1057 Some T' => T' |
1068 in |
1058 | None => |
1069 case find_type (T,tylist) of |
1059 let val T' = (case T of Type (a, Ts) => Type (a, map compress_type Ts) | _ => T) |
1070 Some T' => T' |
1060 in memo_types := Typtab.update ((T', T'), ! memo_types); T' end); |
1071 | None => |
1061 |
1072 let val T' = |
|
1073 case T of |
|
1074 Type (a,Ts) => Type (a, map compress_type Ts) |
|
1075 | _ => T |
|
1076 in memo_types := Symtab.update ((tag, T'::tylist), !memo_types); |
|
1077 T |
|
1078 end |
|
1079 end |
|
1080 handle Match => |
|
1081 let val Type (a,Ts) = T |
|
1082 in Type (a, map compress_type Ts) end; |
|
1083 |
1062 |
1084 (** Sharing of atomic terms **) |
1063 (** Sharing of atomic terms **) |
1085 |
1064 |
1086 val memo_terms = ref (Symtab.empty : term list Symtab.table); |
1065 val memo_terms = ref (Termtab.empty : term Termtab.table); |
1087 |
|
1088 (* special case of library/find_first *) |
|
1089 fun find_term (t, []: term list) = None |
|
1090 | find_term (t, t'::ts) = |
|
1091 if t=t' then Some t' |
|
1092 else find_term (t, ts); |
|
1093 |
|
1094 fun const_tag (Const (a,_)) = a |
|
1095 | const_tag (Free (a,_)) = a |
|
1096 | const_tag (Var ((a,i),_)) = a |
|
1097 | const_tag (t as Bound _) = ".B."; |
|
1098 |
1066 |
1099 fun share_term (t $ u) = share_term t $ share_term u |
1067 fun share_term (t $ u) = share_term t $ share_term u |
1100 | share_term (Abs (a,T,u)) = Abs (a, T, share_term u) |
1068 | share_term (Abs (a, T, u)) = Abs (a, T, share_term u) |
1101 | share_term t = |
1069 | share_term t = |
1102 let val tag = const_tag t |
1070 (case Termtab.lookup (! memo_terms, t) of |
1103 val ts = Symtab.lookup_multi (!memo_terms, tag) |
1071 Some t' => t' |
1104 in |
1072 | None => (memo_terms := Termtab.update ((t, t), ! memo_terms); t)); |
1105 case find_term (t,ts) of |
|
1106 Some t' => t' |
|
1107 | None => (memo_terms := Symtab.update ((tag, t::ts), !memo_terms); |
|
1108 t) |
|
1109 end; |
|
1110 |
1073 |
1111 val compress_term = share_term o map_term_types compress_type; |
1074 val compress_term = share_term o map_term_types compress_type; |
1112 |
1075 |
1113 |
1076 |
1114 (* dummy patterns *) |
1077 (* dummy patterns *) |