Commit 1501f43a authored by Andrei Paskevich's avatar Andrei Paskevich

make term traversal functions take one fnT function

move old fnT+fnF versions of t_map, t_fold, etc. to a submodule
parent 903df0ef
......@@ -34,17 +34,17 @@ let fmla1 : Term.fmla = Term.f_or fmla_true fmla_false
(* printing it *)
open Format
let () = printf "@[formula 1 is:@ %a@]@." Pretty.print_fmla fmla1
let () = printf "@[formula 1 is:@ %a@]@." Pretty.print_term fmla1
(* a propositional goal: A and B implies A *)
let prop_var_A : Term.lsymbol = Term.create_psymbol (Ident.id_fresh "A") []
let prop_var_B : Term.lsymbol = Term.create_psymbol (Ident.id_fresh "B") []
let atom_A : Term.fmla = Term.f_app prop_var_A []
let atom_B : Term.fmla = Term.f_app prop_var_B []
let atom_A : Term.fmla = Term.ps_app prop_var_A []
let atom_B : Term.fmla = Term.ps_app prop_var_B []
let fmla2 : Term.fmla = Term.f_implies (Term.f_and atom_A atom_B) atom_A
let () = printf "@[formula 2 is:@ %a@]@." Pretty.print_fmla fmla2
let () = printf "@[formula 2 is:@ %a@]@." Pretty.print_term fmla2
(* building the task for formula 1 alone *)
......@@ -122,7 +122,7 @@ let int_theory : Theory.theory =
Env.find_theory env ["int"] "Int"
let plus_symbol : Term.lsymbol =
Theory.ns_find_ls int_theory.Theory.th_export ["infix +"]
let two_plus_two : Term.term = Term.t_app plus_symbol [two;two] Ty.ty_int
let two_plus_two : Term.term = Term.fs_app plus_symbol [two;two] Ty.ty_int
let two_plus_two : Term.term = Term.t_app_infer plus_symbol [two;two]
let fmla3 : Term.fmla = Term.f_equ two_plus_two four
......@@ -157,7 +157,7 @@ let x : Term.term = Term.t_var var_x
let x_times_x : Term.term =
Term.t_app_infer mult_symbol [x;x]
let fmla4_aux : Term.fmla =
Term.f_app ge_symbol [x_times_x;zero]
Term.ps_app ge_symbol [x_times_x;zero]
let fmla4_quant : Term.fmla_quant =
Term.f_close_quant [var_x] [] fmla4_aux
let fmla4 : Term.fmla =
......
......@@ -44,39 +44,26 @@ let check_fvs f =
Svs.iter (fun vs -> raise (UnboundVar vs)) fvs;
f
let check_ty = Ty.check_ty_equal
let check_vl ty v = ty_equal_check ty v.vs_ty
let check_tl ty t = ty_equal_check ty (t_type t)
let check_vl ty v = check_ty ty v.vs_ty
let check_tl ty t = check_ty ty (t_type t)
let make_fs_defn fs vl t =
let hd = e_app fs (List.map t_var vl) t.t_ty in
let fd = f_forall_close vl [] (f_equ hd t) in
check_t_ty fs.ls_value t;
List.iter2 check_vl fs.ls_args vl;
fs, Some (fs, check_fvs fd)
let make_ps_defn ps vl f =
let hd = f_app ps (List.map t_var vl) in
let pd = f_forall_close vl [] (f_iff hd f) in
List.iter2 check_vl ps.ls_args vl;
ps, Some (ps, check_fvs pd)
let make_ls_defn ls vl = e_map (make_fs_defn ls vl) (make_ps_defn ls vl)
let make_ls_defn ls vl t =
let hd = t_app ls (List.map t_var vl) t.t_ty in
let hd = e_fold f_equ f_iff hd t in
let fd = f_forall_close vl [] hd in
List.iter2 check_vl ls.ls_args vl;
t_ty_check t ls.ls_value;
ls, Some (ls, check_fvs fd)
let open_ls_defn (_,f) =
let vl, ef = f_open_forall f in
match ef.t_node with
| Tapp (_, [_; t2]) -> vl, t2
| Fbinop (_, _, f2) -> vl, f2
let vl,_,f = match f.t_node with
| Fquant (Fforall,b) -> f_open_quant b
| _ -> [],[],f in
match f.t_node with
| Tapp (_, [_; f])
| Fbinop (_, _, f) -> vl,f
| _ -> assert false
let open_fs_defn ld = let vl,e = open_ls_defn ld in
if e.t_ty = None then assert false else vl,e
let open_ps_defn ld = let vl,e = open_ls_defn ld in
if e.t_ty = None then vl,e else assert false
let ls_defn_axiom (_,f) = f
(** Termination checking for mutually recursive logic declarations *)
......@@ -128,7 +115,7 @@ let build_call_graph cgr syms ls =
in
let rec term vm () t = match t.t_node with
| Tapp (s,tl) when Mls.mem s syms ->
t_fold (term vm) (fmla vm) () t; call vm s tl
t_fold (term vm) () t; call vm s tl
| Tlet ({t_node = Tvar v}, b) when Mvs.mem v vm ->
let u,e = t_open_bound b in
term (Mvs.add u (Mvs.find v vm) vm) () e
......@@ -137,27 +124,15 @@ let build_call_graph cgr syms ls =
let p,t = t_open_branch b in
let vml = match_term vm e [vm] p in
List.iter (fun vm -> term vm () t) vml) bl
| _ -> t_fold (term vm) (fmla vm) () t
and fmla vm () f = match f.t_node with
| Tapp (s,tl) when Mls.mem s syms ->
t_fold (term vm) (fmla vm) () f; call vm s tl
| Tlet ({t_node = Tvar v}, b) when Mvs.mem v vm ->
let u,e = t_open_bound b in
fmla (Mvs.add u (Mvs.find v vm) vm) () e
| Tcase (e,bl) ->
term vm () e; List.iter (fun b ->
let p,f = t_open_branch b in
let vml = match_term vm e [vm] p in
List.iter (fun vm -> fmla vm () f) vml) bl
| Fquant (_,b) ->
let _,_,f = f_open_quant b in fmla vm () f
| _ -> t_fold (term vm) (fmla vm) () f
let _,_,f = f_open_quant b in term vm () f
| _ -> t_fold (term vm) () t
in
fun (vl,e) ->
let i = ref (-1) in
let add vm v = incr i; Mvs.add v (Equal !i) vm in
let vm = List.fold_left add Mvs.empty vl in
e_map (term vm ()) (fmla vm ()) e
term vm () e
let build_call_list cgr ls =
let htb = Hls.create 5 in
......@@ -389,15 +364,14 @@ let syms_ts s ts = Sid.add ts.ts_name s
let syms_ls s ls = Sid.add ls.ls_name s
let syms_ty s ty = ty_s_fold syms_ts s ty
let syms_term s t = t_s_fold syms_ts syms_ls s t
let syms_fmla s f = t_s_fold syms_ts syms_ls s f
let syms_term s t = t_s_fold syms_ty syms_ls s t
let create_ty_decl tdl =
if tdl = [] then raise EmptyDecl;
let add s (ts,_) = Sts.add ts s in
let tss = List.fold_left add Sts.empty tdl in
let check_constr tys ty (syms,news) fs =
check_ty ty (of_option fs.ls_value);
ty_equal_check ty (of_option fs.ls_value);
let add s ty = match ty.ty_node with
| Tyvar v -> Stv.add v s
| _ -> assert false
......@@ -437,7 +411,7 @@ let create_logic_decl ldl =
| Some (s,_) when not (ls_equal s ls) ->
raise (BadLogicDecl (ls, s))
| Some (_,f) ->
syms_fmla syms f, news_id news ls.ls_name
syms_term syms f, news_id news ls.ls_name
| None ->
let syms = option_apply syms (syms_ty syms) ls.ls_value in
let syms = List.fold_left syms_ty syms ls.ls_args in
......@@ -465,7 +439,7 @@ let rec f_pos_ps sps pol f = match f.t_node, pol with
f_pos_ps sps (option_map not pol) f
| Tif (f,g,h), _ ->
f_pos_ps sps None f && f_pos_ps sps pol g && f_pos_ps sps pol h
| _ -> t_all (t_pos_ps sps) (f_pos_ps sps pol) f
| _ -> TermTF.t_all (t_pos_ps sps) (f_pos_ps sps pol) f
let create_ind_decl idl =
if idl = [] then raise EmptyDecl;
......@@ -484,7 +458,7 @@ let create_ind_decl idl =
List.iter2 check_tl ps.ls_args tl;
(try ignore (List.for_all (f_pos_ps sps (Some true)) cls)
with Found ls -> raise (NonPositiveIndDecl (ps, pr, ls)));
syms_fmla syms f, news_id news pr.pr_name
syms_term syms f, news_id news pr.pr_name
| _ -> raise (InvalidIndDecl (ps, pr))
in
let check_decl (syms,news) (ps,al) =
......@@ -496,70 +470,72 @@ let create_ind_decl idl =
mk_decl (Dind idl) syms news
let create_prop_decl k p f =
let syms = syms_fmla Sid.empty f in
let syms = syms_term Sid.empty f in
let news = news_id Sid.empty p.pr_name in
mk_decl (Dprop (k,p,check_fvs f)) syms news
(** Utilities *)
let decl_map fnT fnF d = match d.d_node with
| Dtype _ ->
d
let decl_map fn d = match d.d_node with
| Dtype _ -> d
| Dlogic l ->
let fn = function
| ls, Some ld ->
let vl,e = open_ls_defn ld in
make_ls_defn ls vl (e_map fnT fnF e)
make_ls_defn ls vl (fn e)
| ld -> ld
in
create_logic_decl (List.map fn l)
| Dind l ->
let fn (pr,f) = pr, fnF f in
let fn (pr,f) = pr, fn f in
let fn (ps,l) = ps, List.map fn l in
create_ind_decl (List.map fn l)
| Dprop (k,pr,f) ->
create_prop_decl k pr (fnF f)
create_prop_decl k pr (fn f)
let decl_fold fnT fnF acc d = match d.d_node with
let decl_fold fn acc d = match d.d_node with
| Dtype _ -> acc
| Dlogic l ->
let fn acc = function
| _, Some ld ->
let _,e = open_ls_defn ld in
e_fold fnT fnF acc e
fn acc e
| _ -> acc
in
List.fold_left fn acc l
| Dind l ->
let fn acc (_,f) = fnF acc f in
let fn acc (_,f) = fn acc f in
let fn acc (_,l) = List.fold_left fn acc l in
List.fold_left fn acc l
| Dprop (_,_,f) ->
fnF acc f
fn acc f
let rpair_map_fold f acc (x1,x2) =
let acc, x2 = f acc x2 in
acc, (x1, x2)
let acc, x2 = f acc x2 in acc, (x1, x2)
let list_rpair_map_fold f =
Util.map_fold_left (rpair_map_fold f)
let list_rpair_map_fold f = Util.map_fold_left (rpair_map_fold f)
let decl_map_fold fnT fnF acc d =
match d.d_node with
let decl_map_fold fn acc d = match d.d_node with
| Dtype _ -> acc, d
| Dprop (k,pr,f) ->
let acc, f = t_map_fold fnT fnF acc f in
acc, create_prop_decl k pr f
| Dind l ->
let acc, l =
list_rpair_map_fold (list_rpair_map_fold (t_map_fold fnT fnF)) acc l in
acc, create_ind_decl l
| Dlogic l ->
let acc, l =
list_rpair_map_fold (option_map_fold
(rpair_map_fold (t_map_fold fnT fnF))) acc l in
list_rpair_map_fold (option_map_fold
(rpair_map_fold (t_map_fold fn))) acc l in
acc, create_logic_decl l
| Dind l ->
let acc, l =
list_rpair_map_fold (list_rpair_map_fold
(t_map_fold fn)) acc l in
acc, create_ind_decl l
| Dprop (k,pr,f) ->
let acc, f = t_map_fold fn acc f in
acc, create_prop_decl k pr f
module DeclTF = struct
let decl_map fnT fnF = decl_map (e_map fnT fnF)
let decl_fold fnT fnF = decl_fold (e_fold fnT fnF)
let decl_map_fold fnT fnF = decl_map_fold (e_fold fnT fnF)
end
(** Known identifiers *)
......@@ -630,25 +606,17 @@ let find_prop_decl kn pr =
| Dprop (k,_,f) -> k,f
| _ -> assert false
exception NonExhaustiveExpr of pattern list * expr
exception NonExhaustiveCase of pattern list * term
let rec check_matchT kn () t = match t.t_node with
| Tcase (t1,bl) ->
let bl = List.map (fun b -> let p,t = t_open_branch b in [p],t) bl in
ignore (try Pattern.CompileTerm.compile (find_constructors kn) [t1] bl
with Pattern.NonExhaustive p -> raise (NonExhaustiveExpr (p,t)));
t_fold (check_matchT kn) (check_matchF kn) () t
| _ -> t_fold (check_matchT kn) (check_matchF kn) () t
and check_matchF kn () f = match f.t_node with
| Tcase (t1,bl) ->
let bl = List.map (fun b -> let p,f = t_open_branch b in [p],f) bl in
ignore (try Pattern.CompileTerm.compile (find_constructors kn) [t1] bl
with Pattern.NonExhaustive p -> raise (NonExhaustiveExpr (p,f)));
t_fold (check_matchT kn) (check_matchF kn) () f
| _ -> t_fold (check_matchT kn) (check_matchF kn) () f
with Pattern.NonExhaustive p -> raise (NonExhaustiveCase (p,t)));
t_fold (check_matchT kn) () t
| _ -> t_fold (check_matchT kn) () t
let check_match kn d = decl_fold (check_matchT kn) (check_matchF kn) () d
let check_match kn d = decl_fold (check_matchT kn) () d
exception NonFoundedTypeDecl of tysymbol
......
......@@ -39,13 +39,9 @@ type ls_defn
type logic_decl = lsymbol * ls_defn option
val make_ls_defn : lsymbol -> vsymbol list -> expr -> logic_decl
val make_fs_defn : lsymbol -> vsymbol list -> term -> logic_decl
val make_ps_defn : lsymbol -> vsymbol list -> fmla -> logic_decl
val make_ls_defn : lsymbol -> vsymbol list -> term -> logic_decl
val open_ls_defn : ls_defn -> vsymbol list * expr
val open_fs_defn : ls_defn -> vsymbol list * term
val open_ps_defn : ls_defn -> vsymbol list * fmla
val open_ls_defn : ls_defn -> vsymbol list * term
val ls_defn_axiom : ls_defn -> fmla
......@@ -133,12 +129,21 @@ exception EmptyIndDecl of lsymbol
(** {2 Utilities} *)
val decl_map : (term -> term) -> decl -> decl
val decl_fold : ('a -> term -> 'a) -> 'a -> decl -> 'a
val decl_map_fold : ('a -> term -> 'a * term) -> 'a -> decl -> 'a * decl
module DeclTF : sig
val decl_map : (term -> term) -> (fmla -> fmla) -> decl -> decl
val decl_fold : ('a -> term -> 'a) -> ('a -> fmla -> 'a) -> 'a -> decl -> 'a
val decl_map_fold :
('a -> term -> 'a * term) -> ('a -> fmla -> 'a * fmla) ->
'a -> decl -> 'a * decl
val decl_map_fold : ('a -> term -> 'a * term) ->
('a -> fmla -> 'a * fmla) -> 'a -> decl -> 'a * decl
end
(** {2 Known identifiers} *)
......@@ -151,7 +156,7 @@ val merge_known : known_map -> known_map -> known_map
exception KnownIdent of ident
exception UnknownIdent of ident
exception RedeclaredIdent of ident
exception NonExhaustiveExpr of pattern list * expr
exception NonExhaustiveCase of pattern list * term
exception NonFoundedTypeDecl of tysymbol
val find_constructors : known_map -> tysymbol -> lsymbol list
......
......@@ -136,7 +136,7 @@ let unambig_fs fs =
| Tyvar u when not (lookup u) -> false
| _ -> ty_all inspect ty
in
inspect (of_option fs.ls_value)
option_apply true inspect fs.ls_value
(** Patterns, terms, and formulas *)
......@@ -190,7 +190,6 @@ let print_ident_labels fmt id =
else ()
let rec print_term fmt t = print_lterm 0 fmt t
and print_fmla fmt f = print_lfmla 0 fmt f
and print_lterm pri fmt t = match t.t_label with
| _ when Debug.nottest_flag debug_print_labels
......@@ -199,13 +198,6 @@ and print_lterm pri fmt t = match t.t_label with
| ll -> fprintf fmt (protect_on (pri > 0) "%a %a")
(print_list space print_label) ll (print_tnode 0) t
and print_lfmla pri fmt f = match f.t_label with
| _ when Debug.nottest_flag debug_print_labels
-> print_fnode pri fmt f
| [] -> print_fnode pri fmt f
| ll -> fprintf fmt (protect_on (pri > 0) "%a %a")
(print_list space print_label) ll (print_fnode 0) f
and print_app pri ls fmt tl = match extract_op ls, tl with
| _, [] ->
print_ls fmt ls
......@@ -236,7 +228,7 @@ and print_tnode pri fmt t = match t.t_node with
(print_app 5 fs) tl print_ty (t_type t)
| Tif (f,t1,t2) ->
fprintf fmt (protect_on (pri > 0) "if @[%a@] then %a@ else %a")
print_fmla f print_term t1 print_term t2
print_term f print_term t1 print_term t2
| Tlet (t1,tb) ->
let v,t2 = t_open_bound tb in
fprintf fmt (protect_on (pri > 0) "let %a = @[%a@] in@ %a")
......@@ -248,17 +240,12 @@ and print_tnode pri fmt t = match t.t_node with
| Teps fb ->
let v,f = t_open_bound fb in
fprintf fmt (protect_on (pri > 0) "epsilon %a.@ %a")
print_vsty v print_fmla f;
print_vsty v print_term f;
forget_var v
| Fquant _ | Fbinop _ | Fnot _ | Ftrue | Ffalse -> raise (TermExpected t)
and print_fnode pri fmt f = match f.t_node with
| Tapp (ps,tl) ->
print_app pri ps fmt tl
| Fquant (q,fq) ->
let vl,tl,f = f_open_quant fq in
fprintf fmt (protect_on (pri > 0) "%a %a%a.@ %a") print_quant q
(print_list comma print_vsty) vl print_tl tl print_fmla f;
(print_list comma print_vsty) vl print_tl tl print_term f;
List.iter forget_var vl
| Ftrue ->
fprintf fmt "true"
......@@ -267,37 +254,18 @@ and print_fnode pri fmt f = match f.t_node with
| Fbinop (b,f1,f2) ->
let p = prio_binop b in
fprintf fmt (protect_on (pri > p) "%a %a@ %a")
(print_lfmla (p + 1)) f1 print_binop b (print_lfmla p) f2
(print_lterm (p + 1)) f1 print_binop b (print_lterm p) f2
| Fnot f ->
fprintf fmt (protect_on (pri > 4) "not %a") (print_lfmla 4) f
| Tif (f1,f2,f3) ->
fprintf fmt (protect_on (pri > 0) "if @[%a@] then %a@ else %a")
print_fmla f1 print_fmla f2 print_fmla f3
| Tlet (t,f) ->
let v,f = t_open_bound f in
fprintf fmt (protect_on (pri > 0) "let %a = @[%a@] in@ %a")
print_vs v (print_lterm 4) t print_fmla f;
forget_var v
| Tcase (t,bl) ->
fprintf fmt "match @[%a@] with@\n@[<hov>%a@]@\nend"
print_term t (print_list newline print_fbranch) bl
| Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f)
fprintf fmt (protect_on (pri > 4) "not %a") (print_lterm 4) f
and print_tbranch fmt br =
let p,t = t_open_branch br in
fprintf fmt "@[<hov 4>| %a ->@ %a@]" print_pat p print_term t;
Svs.iter forget_var p.pat_vars
and print_fbranch fmt br =
let p,f = t_open_branch br in
fprintf fmt "@[<hov 4>| %a ->@ %a@]" print_pat p print_fmla f;
Svs.iter forget_var p.pat_vars
and print_tl fmt tl =
if tl = [] then () else fprintf fmt "@ [%a]"
(print_list alt (print_list comma print_expr)) tl
and print_expr fmt = e_map (print_term fmt) (print_fmla fmt)
(print_list alt (print_list comma print_term)) tl
(** Declarations *)
......@@ -340,7 +308,7 @@ let print_logic_decl fst fmt (ls,ld) = match ld with
fprintf fmt "@[<hov 2>%s %a%a%a =@ %a@]"
(if fst then "logic" else "with") print_ls ls
(print_list nothing print_vs_arg) vl
(print_option print_ls_type) ls.ls_value print_expr e;
(print_option print_ls_type) ls.ls_value print_term e;
List.iter forget_var vl
| None ->
fprintf fmt "@[<hov 2>%s %a%a%a@]"
......@@ -352,7 +320,7 @@ let print_logic_decl fst fmt d = print_logic_decl fst fmt d; forget_tvs ()
let print_ind fmt (pr,f) =
fprintf fmt "@[<hov 4>| %a%a : %a@]"
print_pr pr print_ident_labels pr.pr_name print_fmla f
print_pr pr print_ident_labels pr.pr_name print_term f
let print_ind_decl fst fmt (ps,bl) =
fprintf fmt "@[<hov 2>%s %a%a =@ @[<hov>%a@]@]"
......@@ -371,7 +339,7 @@ let print_pkind fmt k = pp_print_string fmt (sprint_pkind k)
let print_prop_decl fmt (k,pr,f) =
fprintf fmt "@[<hov 2>%a %a%a : %a@]" print_pkind k
print_pr pr print_ident_labels pr.pr_name print_fmla f;
print_pr pr print_ident_labels pr.pr_name print_term f;
forget_tvs ()
let print_list_next sep print fmt = function
......@@ -513,7 +481,7 @@ let () = Exn_printer.register
| Term.PredicateSymbolExpected ls ->
fprintf fmt "Not a predicate symbol: %a" print_ls ls
| Term.TermExpected t ->
fprintf fmt "Not a term: %a" print_fmla t
fprintf fmt "Not a term: %a" print_term t
| Term.FmlaExpected t ->
fprintf fmt "Not a formula: %a" print_term t
| Term.NoMatch ->
......@@ -563,9 +531,9 @@ let () = Exn_printer.register
id.id_string
| Decl.NoTerminationProof ls ->
fprintf fmt "Cannot prove the termination of %a" print_ls ls
| Decl.NonExhaustiveExpr (pl, e) ->
| Decl.NonExhaustiveCase (pl, e) ->
fprintf fmt "Pattern @[%a@] is not covered in expression:@\n @[%a@]"
(print_list comma print_pat) pl print_expr e
(print_list comma print_pat) pl print_term e
| _ -> raise exn
end
......@@ -45,8 +45,6 @@ val print_binop : formatter -> binop -> unit (* binary operator *)
val print_const : formatter -> constant -> unit (* int/real constant *)
val print_pat : formatter -> pattern -> unit (* pattern *)
val print_term : formatter -> term -> unit (* term *)
val print_fmla : formatter -> fmla -> unit (* formula *)
val print_expr : formatter -> expr -> unit (* term or formula *)
val print_label : formatter -> label -> unit
val print_pkind : formatter -> prop_kind -> unit
......
......@@ -282,7 +282,7 @@ let () = Exn_printer.register (fun fmt exn -> match exn with
Pretty.print_ts e s
| UnsupportedTerm (e,s) ->
fprintf fmt "@[<hov 3> This expression isn't supported:@\n%a@\n%s@]"
Pretty.print_expr e s
Pretty.print_term e s
| UnsupportedDecl (d,s) ->
fprintf fmt "@[<hov 3> This declaration isn't supported:@\n%a@\n%s@]"
Pretty.print_decl d s
......
This diff is collapsed.
This diff is collapsed.
......@@ -459,7 +459,7 @@ let cl_find_ls cl ls =
cl.ls_table <- Mls.add ls ls' cl.ls_table;
ls'
let cl_trans_fmla cl f = t_s_map (cl_find_ts cl) (cl_find_ls cl) f
let cl_trans_fmla cl f = t_s_map (cl_trans_ty cl) (cl_find_ls cl) f
let cl_find_pr cl pr =
if not (Sid.mem pr.pr_name cl.cl_local) then pr
......@@ -532,18 +532,12 @@ let cl_type cl inst tdl =
create_ty_decl (List.fold_right add_type tdl [])
let extract_ls_defn f =
let vl, ef = f_open_forall f in
match ef.t_node with
| Tapp (s, [t1; t2]) when ls_equal s ps_equ ->
begin match t1.t_node with
| Tapp (fs, _) -> make_fs_defn fs vl t2
| _ -> assert false
end
| Fbinop (Fiff, f1, f2) ->
begin match f1.t_node with
| Tapp (ps, _) -> make_ps_defn ps vl f2
| _ -> assert false
end
let vl,_,f = match f.t_node with
| Fquant (Fforall,b) -> f_open_quant b
| _ -> [],[],f in
match f.t_node with
| Tapp (_, [{t_node = Tapp (ls,_)}; f])
| Fbinop (_, {t_node = Tapp (ls,_)}, f) -> make_ls_defn ls vl f
| _ -> assert false
let cl_logic cl inst ldl =
......
......@@ -131,7 +131,8 @@ let goal_l = gen_goal_l add_decl
let tgoal = gen_goal add_tdecl
let tgoal_l = gen_goal_l add_tdecl
let rewrite fnT fnF = decl (fun d -> [decl_map fnT fnF d])
let rewrite fn = decl (fun d -> [decl_map fn d])
let rewriteTF fnT fnF = rewrite (e_map fnT fnF)
let gen_add_decl add decls = function
| Some { task_decl = { td_node = Decl d }; task_prev = prev } ->
......
......@@ -68,7 +68,8 @@ val goal_l : (prsymbol -> fmla -> decl list list) -> task tlist
val tgoal : (prsymbol -> fmla -> tdecl list ) -> task trans
val tgoal_l : (prsymbol -> fmla -> tdecl list list) -> task tlist
val rewrite : (term -> term) -> (fmla -> fmla) -> task -> task trans
val rewrite : (term -> term) -> task -> task trans
val rewriteTF : (term -> term) -> (fmla -> fmla) -> task -> task trans
val add_decls : decl list -> task trans
val add_tdecls : tdecl list -> task trans
......
......@@ -239,21 +239,13 @@ let is_ts_tuple ts = ts_equal ts (ts_tuple (List.length ts.ts_args))
(** {2 Operations on [ty option]} *)
type oty = ty option
exception UnexpectedProp
let oty_ty = function Some ty -> ty | None -> raise UnexpectedProp
let oty_type = function Some ty -> ty | None -> raise UnexpectedProp
let oty_equal = Util.option_eq ty_equal
let oty_hash = Util.option_apply 1 ty_hash
let oty_map = Util.option_map
let oty_iter = Util.option_iter
let oty_apply = Util.option_apply
let oty_fold = Util.option_fold
let oty_map_fold = Util.option_map_fold
let oty_match m o1 o2 = match o1,o2 with
| Some ty1, Some ty2 -> ty_match m ty1 ty2
| None, None -> m
......@@ -263,6 +255,6 @@ let oty_inst m = Util.option_map (ty_inst m)
let oty_freevars = Util.option_fold ty_freevars
let oty_cons = Util.option_fold (fun tl t -> t::tl)
let check_ty_equal ty1 ty2 =
let ty_equal_check ty1 ty2 =
if not (ty_equal ty1 ty2) then raise (TypeMismatch (ty1, ty2))
......@@ -97,10 +97,9 @@ exception TypeMismatch of ty * ty
val ty_match : ty Mtv.t -> ty -> ty -> ty Mtv.t
val ty_inst : ty Mtv.t -> ty -> ty
val ty_freevars : Stv.t -> ty -> Stv.t
val check_ty_equal : ty -> ty -> unit
val ty_equal_check : ty -> ty -> unit
(* built-in symbols *)
......@@ -123,21 +122,15 @@ val is_ts_tuple : tysymbol -> bool
(** {2 Operations on [ty option]} *)
type oty = ty option
exception UnexpectedProp
val oty_equal : oty -> oty -> bool
val oty_hash : oty -> int
val oty_equal : ty option -> ty option -> bool
val oty_hash : ty option -> int
val oty_ty : oty -> ty
val oty_map : (ty -> ty) -> oty -> oty
val oty_iter : (ty -> unit) -> oty -> unit
val oty_apply : 'a -> (ty -> 'a) -> oty -> 'a
val oty_fold : ('a -> ty -> 'a) -> 'a -> oty -> 'a
val oty_map_fold : ('a -> ty -> 'a * ty) -> 'a -> oty -> 'a * oty
val oty_type : ty option -> ty
val oty_cons : ty list -> ty option -> ty list
val oty_match : ty Mtv.t -> oty -> oty -> ty Mtv.t
val oty_inst : ty Mtv.t -> oty -> oty
val oty_freevars : Stv.t -> oty -> Stv.t
val oty_match : ty Mtv.t -> ty option -> ty option -> ty Mtv.t
val oty_inst : ty Mtv.t -> ty option -> ty option
val oty_freevars : Stv.t -> ty option -> Stv.t
......@@ -2069,13 +2069,9 @@ let color_loc loc =
let f, l, b, e = Loc.get loc in
if f = !current_file then color_loc source_view l b e
let rec color_f_locs () f =
let rec color_t_locs () f =
Util.option_iter color_loc f.Term.t_loc;
Term.t_fold color_t_locs color_f_locs () f
and color_t_locs () t =
Util.option_iter color_loc t.Term.t_loc;
Term.t_fold color_t_locs color_f_locs () t
Term.t_fold color_t_locs () f
let scroll_to_source_goal g =
let t = g.Model.task in
......@@ -2086,7 +2082,7 @@ let scroll_to_source_goal g =
{ Task.task_decl =
{ Theory.td_node =
Theory.Decl { Decl.d_node = Decl.Dprop (Decl.Pgoal, _, f)}}} ->
color_f_locs () f
color_t_locs () f
| _ ->