Commit 2d3b47ba authored by Andrei Paskevich's avatar Andrei Paskevich

"Please, don't shoot, I can explain everything" commit

- unify Lfunction and Lpredicate (mucho bettar)
- separation of prop and fmla
- making prop and tvsymbol private aliases of ident
parent a20e5f3a
......@@ -25,7 +25,7 @@ open Ty
open Term
open Theory
let iprinter,tprinter,lprinter,cprinter,pprinter =
let iprinter,tprinter,lprinter,pprinter =
let bl = ["theory"; "type"; "logic"; "inductive";
"axiom"; "lemma"; "goal"; "use"; "clone";
"namespace"; "import"; "export"; "end";
......@@ -39,7 +39,6 @@ let iprinter,tprinter,lprinter,cprinter,pprinter =
create_ident_printer bl ~sanitizer:isanitize,
create_ident_printer bl ~sanitizer:lsanitize,
create_ident_printer bl ~sanitizer:lsanitize,
create_ident_printer bl ~sanitizer:usanitize,
create_ident_printer bl ~sanitizer:usanitize
let thash = Hid.create 63
......@@ -50,7 +49,6 @@ let forget_all () =
forget_all iprinter;
forget_all tprinter;
forget_all lprinter;
forget_all cprinter;
forget_all pprinter;
Hid.clear thash;
Hid.clear lhash;
......@@ -60,9 +58,9 @@ let tv_set = ref Sid.empty
(* type variables always start with a quote *)
let print_tv fmt tv =
tv_set := Sid.add tv !tv_set;
tv_set := Sid.add (tv_name tv) !tv_set;
let sanitize n = "'" ^ n in
let n = id_unique iprinter ~sanitizer:sanitize tv in
let n = id_unique iprinter ~sanitizer:sanitize (tv_name tv) in
fprintf fmt "%s" n
let forget_tvs () =
......@@ -89,12 +87,15 @@ let print_ts fmt ts =
let print_ls fmt ls =
Hid.replace lhash ls.ls_name ls;
if ls.ls_constr then fprintf fmt "%s" (id_unique cprinter ls.ls_name)
else fprintf fmt "%s" (id_unique lprinter ls.ls_name)
let n = if ls.ls_constr
then id_unique lprinter ~sanitizer:String.capitalize ls.ls_name
else id_unique lprinter ls.ls_name
in
fprintf fmt "%s" n
let print_pr fmt pr =
Hid.replace phash pr.pr_name pr;
fprintf fmt "%s" (id_unique pprinter pr.pr_name)
Hid.replace phash (pr_name pr) pr;
fprintf fmt "%s" (id_unique pprinter (pr_name pr))
(** Types *)
......@@ -248,8 +249,8 @@ and print_tl fmt tl =
(print_list alt (print_list comma print_tr)) tl
and print_tr fmt = function
| TrTerm t -> print_term fmt t
| TrFmla f -> print_fmla fmt f
| Term t -> print_term fmt t
| Fmla f -> print_fmla fmt f
(** Declarations *)
......@@ -278,37 +279,30 @@ let print_type_decl fmt (ts,def) = match def with
let print_type_decl fmt d = print_type_decl fmt d; forget_tvs ()
let print_logic_decl fmt = function
| Lfunction (fs,None) ->
fprintf fmt "@[<hov 2>logic %a%a :@ %a@]"
print_ls fs (print_paren_l print_ty) fs.ls_args
print_ty (of_option fs.ls_value)
| Lpredicate (ps,None) ->
fprintf fmt "@[<hov 2>logic %a%a@]"
print_ls ps (print_paren_l print_ty) ps.ls_args
| Lfunction (fs,Some fd) ->
let _,vl,t = open_fs_defn fd in
fprintf fmt "@[<hov 2>logic %a%a :@ %a =@ %a@]"
print_ls fs (print_paren_l print_vsty) vl
print_ty t.t_ty print_term t;
List.iter forget_var vl
| Lpredicate (ps,Some fd) ->
let _,vl,f = open_ps_defn fd in
fprintf fmt "@[<hov 2>logic %a%a =@ %a@]"
print_ls ps (print_paren_l print_vsty) vl print_fmla f;
List.iter forget_var vl
let print_logic_decl fmt d = print_logic_decl fmt d; forget_tvs ()
let print_prop fmt pr =
fprintf fmt "%a : %a" print_pr pr print_fmla pr.pr_fmla
let print_ld fmt ld =
let _,vl,e = open_ls_defn ld in
begin match e with
| Term t -> print_term fmt t
| Fmla f -> print_fmla fmt f
end;
List.iter forget_var vl
let print_ls_defn fmt = option_iter (fprintf fmt " =@ %a" print_ld)
let print_ls_type fmt = option_iter (fprintf fmt " :@ %a" print_ty)
let print_logic_decl fmt (ls,ld) =
fprintf fmt "@[<hov 2>logic %a%a%a%a@]"
print_ls ls (print_paren_l print_ty) ls.ls_args
print_ls_type ls.ls_value print_ls_defn ld;
forget_tvs ()
let print_ind fmt pr = fprintf fmt "@[<hov 4>| %a@]" print_prop pr
let print_ind fmt (pr,f) =
fprintf fmt "@[<hov 4>| %a : %a@]" print_pr pr print_fmla f
let print_ind_decl fmt (ps,bl) =
fprintf fmt "@[<hov 2>inductive %a%a =@ @[<hov>%a@]@]"
print_ls ps (print_paren_l print_ty) ps.ls_args
(print_list newline print_ind) bl;
print_ls ps (print_paren_l print_ty) ps.ls_args
(print_list newline print_ind) bl;
forget_tvs ()
let print_pkind fmt = function
......@@ -316,6 +310,11 @@ let print_pkind fmt = function
| Plemma -> fprintf fmt "lemma"
| Pgoal -> fprintf fmt "goal"
let print_prop_decl fmt (k,pr,f) =
fprintf fmt "@[<hov 2>%a %a : %a@]" print_pkind k
print_pr pr print_fmla f;
forget_tvs ()
let print_inst fmt (id1,id2) =
if Hid.mem thash id2 then
let n = id_unique tprinter id1 in
......@@ -332,9 +331,7 @@ let print_decl fmt d = match d.d_node with
| Dtype tl -> print_list newline print_type_decl fmt tl
| Dlogic ll -> print_list newline print_logic_decl fmt ll
| Dind il -> print_list newline print_ind_decl fmt il
| Dprop (k,pr) ->
fprintf fmt "@[<hov 2>%a %a@]" print_pkind k print_prop pr;
forget_tvs ()
| Dprop p -> print_prop_decl fmt p
| Duse th ->
fprintf fmt "@[<hov 2>(* use %a *)@]" print_th th
| Dclone (th,inst) ->
......
......@@ -42,12 +42,12 @@ val print_pat : formatter -> pattern -> unit (* pattern *)
val print_term : formatter -> term -> unit (* term *)
val print_fmla : formatter -> fmla -> unit (* formula *)
val print_pkind : formatter -> prop_kind -> unit
val print_type_decl : formatter -> ty_decl -> unit
val print_logic_decl : formatter -> logic_decl -> unit
val print_ind_decl : formatter -> ind_decl -> unit
val print_pkind : formatter -> prop_kind -> unit
val print_prop : formatter -> prop -> unit
val print_prop_decl : formatter -> prop_decl -> unit
val print_decl : formatter -> decl -> unit
val print_decls : formatter -> decl list -> unit
......
......@@ -164,7 +164,7 @@ exception PredicateSymbolExpected of lsymbol
let pat_app fs pl ty =
if not fs.ls_constr then raise (ConstructorExpected fs);
let s = match fs.ls_value with
| Some vty -> Ty.matching Mid.empty vty ty
| Some vty -> Ty.matching Mtv.empty vty ty
| None -> raise (FunctionSymbolExpected fs)
in
let mtch s ty p = Ty.matching s ty p.pat_ty in
......@@ -260,20 +260,20 @@ and term_branch = pattern * int * term
and fmla_branch = pattern * int * fmla
and trigger_elt =
| TrTerm of term
| TrFmla of fmla
and expr =
| Term of term
| Fmla of fmla
and trigger = trigger_elt list
and trigger = expr list
(* trigger traversal *)
let tr_map fnT fnF =
let fn = function TrTerm t -> TrTerm (fnT t) | TrFmla f -> TrFmla (fnF f) in
let fn = function Term t -> Term (fnT t) | Fmla f -> Fmla (fnF f) in
List.map (List.map fn)
let tr_fold fnT fnF =
let fn acc = function TrTerm t -> fnT acc t | TrFmla f -> fnF acc f in
let fn acc = function Term t -> fnT acc t | Fmla f -> fnF acc f in
List.fold_left (List.fold_left fn)
module T = struct
......@@ -344,8 +344,8 @@ module F = struct
let f_eq_bound (v1, f1) (v2, f2) = v1 == v2 && f1 == f2
let tr_eq tr1 tr2 = match tr1,tr2 with
| TrTerm t1, TrTerm t2 -> t1 == t2
| TrFmla f1, TrFmla f2 -> f1 == f2
| Term t1, Term t2 -> t1 == t2
| Fmla f1, Fmla f2 -> f1 == f2
| _ -> false
let f_eq_quant (vl1, n1, tl1, f1) (vl2, n2, tl2, f2) =
......@@ -391,7 +391,7 @@ module F = struct
let f_hash_bound (v, f) = Hashcons.combine v.vs_name.id_tag f.f_tag
let tr_hash = function TrTerm t -> t.t_tag | TrFmla f -> f.f_tag
let tr_hash = function Term t -> t.t_tag | Fmla f -> f.f_tag
let f_hash_quant (vl, _, tl, f) =
let h = Hashcons.combine_list v_hash f.f_tag vl in
......@@ -560,7 +560,7 @@ let f_any_unsafe prT prF lvl f =
let t_app fs tl ty =
let s = match fs.ls_value with
| Some vty -> Ty.matching Mid.empty vty ty
| Some vty -> Ty.matching Mtv.empty vty ty
| _ -> raise (FunctionSymbolExpected fs)
in
let mtch s ty t = Ty.matching s ty t.t_ty in
......@@ -570,7 +570,7 @@ let t_app fs tl ty =
let f_app ps tl =
let s = match ps.ls_value with
| None -> Mid.empty
| None -> Mtv.empty
| _ -> raise (PredicateSymbolExpected ps)
in
let mtch s ty t = Ty.matching s ty t.t_ty in
......
......@@ -152,11 +152,11 @@ and term_branch
and fmla_branch
and trigger_elt =
| TrTerm of term
| TrFmla of fmla
and expr =
| Term of term
| Fmla of fmla
and trigger = trigger_elt list
and trigger = expr list
module Mterm : Map.S with type key = term
module Sterm : Set.S with type elt = term
......
......@@ -26,38 +26,16 @@ open Termlib
(** Named propositions *)
type prop = {
pr_name : ident;
pr_fmla : fmla;
}
module Prop = struct
type t = prop
let equal = (==)
let hash pr = pr.pr_name.id_tag
let compare pr1 pr2 =
Pervasives.compare pr1.pr_name.id_tag pr2.pr_name.id_tag
end
module Mpr = Map.Make(Prop)
module Spr = Set.Make(Prop)
module Hpr = Hashtbl.Make(Prop)
type prop = ident
exception UnboundVars of Svs.t
module Spr = Sid
module Mpr = Mid
module Hpr = Hid
let check_fvs f =
let fvs = f_freevars Svs.empty f in
if Svs.is_empty fvs then f else raise (UnboundVars fvs)
let create_prop = id_register
let pr_name x = x
let create_prop n f = {
pr_name = id_register n;
pr_fmla = check_fvs f;
}
let shortcut_for_discussion_dont_be_mad_andrei_please n f =
{
pr_name = n;
pr_fmla = check_fvs f;
}
exception UnboundVars of Svs.t
(** Declarations *)
......@@ -71,55 +49,61 @@ type ty_decl = tysymbol * ty_def
(* logic declaration *)
type fs_defn = lsymbol * vsymbol list * term * fmla
type ps_defn = lsymbol * vsymbol list * fmla * fmla
type ls_defn = lsymbol * vsymbol list * expr * fmla
type logic_decl =
| Lfunction of lsymbol * fs_defn option
| Lpredicate of lsymbol * ps_defn option
type logic_decl = lsymbol * ls_defn option
exception IllegalConstructor of lsymbol
let check_fvs f =
let fvs = f_freevars Svs.empty f in
if Svs.is_empty fvs then f else raise (UnboundVars fvs)
let make_fs_defn fs vl t =
if fs.ls_constr then raise (IllegalConstructor fs);
let hd = t_app fs (List.map t_var vl) t.t_ty in
let fd = f_forall vl [] (f_equ hd t) in
fs, vl, t, check_fvs fd
fs, vl, Term t, 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 vl [] (f_iff hd f) in
ps, vl, f, check_fvs pd
ps, vl, Fmla f, check_fvs pd
let extract_fs_defn f =
let make_ls_defn ls vl = function
| Term t -> make_fs_defn ls vl t
| Fmla f -> make_ps_defn ls vl f
let extract_ls_defn f =
let vl, ef = f_open_forall f in
match ef.f_node with
| Fapp (s, [t1; t2]) when s == ps_equ ->
begin match t1.t_node with
| Tapp (fs, _) -> fs, (fs, vl, t2, f)
| Tapp (fs, _) -> fs, Some (fs, vl, Term t2, f)
| _ -> assert false
end
| _ -> assert false
let extract_ps_defn f =
let vl, ef = f_open_forall f in
match ef.f_node with
| Fbinop (Fiff, f1, f2) ->
begin match f1.f_node with
| Fapp (ps, _) -> ps, (ps, vl, f2, f)
| Fapp (ps, _) -> ps, Some (ps, vl, Fmla f2, f)
| _ -> assert false
end
| _ -> assert false
let open_fs_defn (fs,vl,t,_) = (fs,vl,t)
let open_ps_defn (ps,vl,f,_) = (ps,vl,f)
let open_ls_defn (ls,vl,e,_) = (ls,vl,e)
let open_fs_defn = function
| (fs,vl,Term t,_) -> (fs,vl,t)
| _ -> assert false
let open_ps_defn = function
| (ps,vl,Fmla f,_) -> (ps,vl,f)
| _ -> assert false
let fs_defn_axiom (_,_,_,fd) = fd
let ps_defn_axiom (_,_,_,pd) = pd
let ls_defn_axiom (_,_,_,f) = f
(* inductive predicate declaration *)
type ind_decl = lsymbol * prop list
type ind_decl = lsymbol * (prop * fmla) list
(* proposition declaration *)
......@@ -128,7 +112,7 @@ type prop_kind =
| Plemma
| Pgoal
type prop_decl = prop_kind * prop
type prop_decl = prop_kind * prop * fmla
(** Context and Theory *)
......@@ -193,23 +177,21 @@ module Decl = struct
| Talgebraic l1, Talgebraic l2 -> for_all2 (==) l1 l2
| _ -> false
let eq_fd fs1 fd1 fs2 fd2 = fs1 == fs2 && match fd1,fd2 with
| Some (_,_,_,fd1), Some (_,_,_,fd2) -> fd1 == fd2
let eq_ld (ls1,ld1) (ls2,ld2) = ls1 == ls2 && match ld1,ld2 with
| Some (_,_,_,f1), Some (_,_,_,f2) -> f1 == f2
| None, None -> true
| _ -> false
let eq_ld ld1 ld2 = match ld1,ld2 with
| Lfunction (fs1,fd1), Lfunction (fs2,fd2) -> eq_fd fs1 fd1 fs2 fd2
| Lpredicate (ps1,pd1), Lpredicate (ps2,pd2) -> eq_fd ps1 pd1 ps2 pd2
| _ -> false
let eq_iax (pr1,fr1) (pr2,fr2) = pr1 == pr1 && fr1 == fr2
let eq_ind (ps1,al1) (ps2,al2) = ps1 == ps2 && for_all2 (==) al1 al2
let eq_ind (ps1,al1) (ps2,al2) = ps1 == ps2 && for_all2 eq_iax al1 al2
let equal d1 d2 = match d1.d_node, d2.d_node with
| Dtype l1, Dtype l2 -> for_all2 eq_td l1 l2
| Dlogic l1, Dlogic l2 -> for_all2 eq_ld l1 l2
| Dind l1, Dind l2 -> for_all2 eq_ind l1 l2
| Dprop (k1,pr1), Dprop (k2,pr2) -> k1 == k2 && pr1 == pr2
| Dprop (k1,pr1,f1), Dprop (k2,pr2,f2) ->
k1 == k2 && pr1 == pr2 && f1 == f2
| Duse th1, Duse th2 -> th1.th_name == th2.th_name
| Dclone (th1,sl1), Dclone (th2,sl2) -> th1.th_name == th2.th_name
&& for_all2 (fun (i,i') (j,j') -> i == j && i' == j') sl1 sl2
......@@ -221,23 +203,23 @@ module Decl = struct
let tag fs = fs.ls_name.id_tag in
1 + Hashcons.combine_list tag ts.ts_name.id_tag l
let hs_fd fd = Hashcons.combine_option (fun (_,_,_,f) -> f.f_tag) fd
let hs_ld ld = match ld with
| Lfunction (fs,fd) -> Hashcons.combine fs.ls_name.id_tag (hs_fd fd)
| Lpredicate (ps,pd) -> Hashcons.combine ps.ls_name.id_tag (hs_fd pd)
let hs_ld (ls,ld) = Hashcons.combine ls.ls_name.id_tag
(Hashcons.combine_option (fun (_,_,_,f) -> f.f_tag) ld)
let hs_ind (ps,al) =
let hs_pair pr = pr.pr_name.id_tag in
let hs_pair (pr,f) = Hashcons.combine pr.id_tag f.f_tag in
Hashcons.combine_list hs_pair ps.ls_name.id_tag al
let hs_kind = function
| Paxiom -> 7
| Plemma -> 11
| Pgoal -> 13
let hash d = match d.d_node with
| Dtype l -> Hashcons.combine_list hs_td 0 l
| Dlogic l -> Hashcons.combine_list hs_ld 3 l
| Dind l -> Hashcons.combine_list hs_ind 5 l
| Dprop (Paxiom,pr) -> Hashcons.combine 7 pr.pr_name.id_tag
| Dprop (Plemma,pr) -> Hashcons.combine 11 pr.pr_name.id_tag
| Dprop (Pgoal, pr) -> Hashcons.combine 13 pr.pr_name.id_tag
| Dprop (k,pr,f) -> Hashcons.combine2 (hs_kind k) pr.id_tag f.f_tag
| Duse th -> Hashcons.combine 17 th.th_name.id_tag
| Dclone (th,sl) ->
let tag = Hashcons.combine 19 th.th_name.id_tag in
......@@ -260,14 +242,12 @@ let mk_decl n = { d_node = n; d_tag = -1 }
let create_ty_decl tdl = Hdecl.hashcons (mk_decl (Dtype tdl))
let create_logic_decl ldl = Hdecl.hashcons (mk_decl (Dlogic ldl))
let create_ind_decl idl = Hdecl.hashcons (mk_decl (Dind idl))
let create_prop_decl k p = Hdecl.hashcons (mk_decl (Dprop (k, p)))
let create_prop_decl k p f = Hdecl.hashcons (mk_decl (Dprop (k,p,f)))
let create_use_decl th = Hdecl.hashcons (mk_decl (Duse th))
let create_clone_decl th sl = Hdecl.hashcons (mk_decl (Dclone (th,sl)))
let prop_decl_of_fmla k n f = create_prop_decl k (create_prop n f)
exception ConstructorExpected of lsymbol
exception UnboundTypeVar of ident
exception UnboundTypeVar of tvsymbol
exception IllegalTypeAlias of tysymbol
exception ClashIdent of ident
exception BadLogicDecl of ident
......@@ -282,14 +262,14 @@ let create_ty_decl tdl =
let check_constr ty acc fs =
if not fs.ls_constr then raise (ConstructorExpected fs);
let vty = of_option fs.ls_value in
ignore (Ty.matching Mid.empty vty ty);
ignore (Ty.matching Mtv.empty vty ty);
let add s ty = match ty.ty_node with
| Tyvar v -> Sid.add v s
| Tyvar v -> Stv.add v s
| _ -> assert false
in
let vs = ty_fold add Sid.empty vty in
let vs = ty_fold add Stv.empty vty in
let rec check () ty = match ty.ty_node with
| Tyvar v -> if not (Sid.mem v vs) then raise (UnboundTypeVar v)
| Tyvar v -> if not (Stv.mem v vs) then raise (UnboundTypeVar v)
| _ -> ty_fold check () ty
in
List.iter (check ()) fs.ls_args;
......@@ -307,20 +287,16 @@ let create_ty_decl tdl =
let create_logic_decl ldl =
if ldl = [] then raise EmptyDecl;
let check_decl acc = function
| Lfunction (fs, Some (s,_,_,_)) when s != fs ->
raise (BadLogicDecl fs.ls_name)
| Lpredicate (ps, Some (s,_,_,_)) when s != ps ->
raise (BadLogicDecl ps.ls_name)
| Lfunction (fs, _) -> add_id acc fs.ls_name
| Lpredicate (ps, _) -> add_id acc ps.ls_name
let check_decl acc (ls,ld) = match ld with
| Some (s,_,_,_) when s != ls -> raise (BadLogicDecl ls.ls_name)
| _ -> add_id acc ls.ls_name
in
ignore (List.fold_left check_decl Sid.empty ldl);
create_logic_decl ldl
exception InvalidIndDecl of ident * ident
exception TooSpecificIndDecl of ident * ident * term
exception NonPositiveIndDecl of ident * ident * lsymbol
exception InvalidIndDecl of lsymbol * prop
exception TooSpecificIndDecl of lsymbol * prop * term
exception NonPositiveIndDecl of lsymbol * prop * lsymbol
exception Found of lsymbol
let ls_mem s sps = if Sls.mem s sps then raise (Found s) else false
......@@ -343,8 +319,8 @@ let create_ind_decl idl =
if idl = [] then raise EmptyDecl;
let add acc (ps,_) = Sls.add ps acc in
let sps = List.fold_left add Sls.empty idl in
let check_ax ps acc pr =
let _, f = f_open_forall pr.pr_fmla in
let check_ax ps acc (pr,f) =
let _, f = f_open_forall f in
let rec clause acc f = match f.f_node with
| Fbinop (Fimplies, g, f) -> clause (g::acc) f
| _ -> (acc, f)
......@@ -354,14 +330,14 @@ let create_ind_decl idl =
| Fapp (s, tl) when s == ps ->
let tymatch sb t ty =
try Ty.matching sb (t.t_ty) ty with TypeMismatch ->
raise (TooSpecificIndDecl (ps.ls_name, pr.pr_name, t))
raise (TooSpecificIndDecl (ps, pr, t))
in
ignore (List.fold_left2 tymatch Mid.empty tl ps.ls_args);
ignore (List.fold_left2 tymatch Mtv.empty tl ps.ls_args);
(try ignore (List.for_all (f_pos_ps sps (Some true)) cls)
with Found ls ->
raise (NonPositiveIndDecl (ps.ls_name, pr.pr_name, ls)));
add_id acc pr.pr_name
| _ -> raise (InvalidIndDecl (ps.ls_name, pr.pr_name))
raise (NonPositiveIndDecl (ps, pr, ls)));
add_id acc (pr_name pr)
| _ -> raise (InvalidIndDecl (ps, pr))
in
let check_decl acc (ps,al) =
List.fold_left (check_ax ps) (add_id acc ps.ls_name) al
......@@ -406,18 +382,16 @@ let get_ty_dep next loan (ts,td) =
| Tabstract -> loan
| Talgebraic fdl -> List.fold_left cns loan fdl
let get_logic_id = function
| Lfunction (fs,_) -> fs.ls_name
| Lpredicate (ps,_) -> ps.ls_name
let get_logic_id (ls,_) = ls.ls_name
let get_logic_dep next loan ld =
let get_logic_dep next loan (_,ld) =
let dts acc _ = acc in
let dep acc ls = if Sid.mem ls.ls_name next
then Sid.add ls.ls_name acc else acc in
match ld with
| Lfunction (_, Some (_,_,t,_)) -> t_s_fold dts dep loan t
| Lpredicate (_, Some (_,_,f,_)) -> f_s_fold dts dep loan f
| _ -> loan
| Some (_,_,Term t,_) -> t_s_fold dts dep loan t
| Some (_,_,Fmla f,_) -> f_s_fold dts dep loan f
| None -> loan
let get_ind_id (ps,_) = ps.ls_name
......@@ -425,7 +399,7 @@ let get_ind_dep next loan (_,al) =
let dts acc _ = acc in
let dep acc ls = if Sid.mem ls.ls_name next
then Sid.add ls.ls_name acc else acc in
let prp acc pr = f_s_fold dts dep acc pr.pr_fmla in
let prp acc (_,f) = f_s_fold dts dep acc f in
List.fold_left prp loan al
let create_ty_decls tdl =
......@@ -484,8 +458,8 @@ let builtin_name = "BuiltIn"
let builtin_theory env =
let decl_int = create_ty_decl [ts_int, Tabstract] in
let decl_real = create_ty_decl [ts_real, Tabstract] in
let decl_equ = create_logic_decl [Lpredicate (ps_equ, None)] in
let decl_neq = create_logic_decl [Lpredicate (ps_neq, None)] in
let decl_equ = create_logic_decl [ps_equ, None] in
let decl_neq = create_logic_decl [ps_neq, None] in
let kn_int = Mid.add ts_int.ts_name decl_int Mid.empty in
let kn_real = Mid.add ts_real.ts_name decl_real kn_int in
......@@ -624,29 +598,24 @@ module Context = struct
| Tabstract -> option_iter (known_ty kn) ts.ts_def
| Talgebraic lfs -> List.iter check_constr lfs
let add_logic d kn = function
| Lfunction (fs, df) -> add_known fs.ls_name d kn
| Lpredicate (ps, dp) -> add_known ps.ls_name d kn
let check_logic kn d =
let check chk (_,_,e,_) = chk e in
match d with
| Lfunction (fs, df) ->
known_ty kn (of_option fs.ls_value);
List.iter (known_ty kn) fs.ls_args;
option_iter (check (known_term kn)) df
| Lpredicate (ps, dp) ->
List.iter (known_ty kn) ps.ls_args;
option_iter (check (known_fmla kn)) dp
let add_logic d kn (ls,_) = add_known ls.ls_name d kn
let check_logic kn (ls,ld) =
List.iter (known_ty kn) ls.ls_args;
option_iter (known_ty kn) ls.ls_value;
match ld with
| Some (_,_,Term t,_) -> known_term kn t
| Some (_,_,Fmla f,_) -> known_fmla kn f
| None -> ()
let add_ind d kn (ps,la) =
let kn = add_known ps.ls_name d kn in
let add kn pr = add_known pr.pr_name d kn in
let add kn (pr,_) = add_known pr d kn in
List.fold_left add kn la
let check_ind kn (ps,la) =
List.iter (known_ty kn) ps.ls_args;
let check pr = known_fmla kn pr.pr_fmla in
let check (_,f) = known_fmla kn f in
List.iter check la
let add_decl ctxt d =
......@@ -656,7 +625,7 @@ module Context = struct
| Dtype dl -> List.fold_left (add_type d) kn dl
| Dlogic dl -> List.fold_left (add_logic d) kn dl
| Dind dl -> List.fold_left (add_ind d) kn dl
| Dprop (k,pr) -> add_known pr.pr_name d kn
| Dprop (_,pr,_) -> add_known pr d kn
| Duse th -> add_known th.th_name d kn
| Dclone _ -> kn
in
......@@ -664,7 +633,7 @@ module Context = struct
| Dtype dl -> List.iter (check_type kn) dl
| Dlogic dl -> List.iter (check_logic kn) dl
| Dind dl -> List.iter (check_ind kn) dl
| Dprop (_,pr) -> known_fmla kn pr.pr_fmla
| Dprop (_,_,f) -> known_fmla kn f
| Duse _ | Dclone _ -> ()
in
push_decl ctxt kn d
......@@ -704,9 +673,9 @@ module Context = struct
ignore (add_known th.th_name d ctxt.ctxt_known);
let add_decl ctxt d = match d.d_node with
| Duse th -> use_export true ctxt th
| Dprop (Pgoal,_) when hide -> ctxt
| Dprop (Plemma,pr) when hide ->
add_decl ctxt (create_prop_decl Paxiom pr)
| Dprop (Pgoal,_,_) when hide -> ctxt
| Dprop (Plemma,pr,f) when hide ->
add_decl ctxt (create_prop_decl Paxiom pr f)
| _ -> add_decl ctxt d
in
let decls = get_decls th.th_ctxt in
......@@ -746,7 +715,7 @@ module Context = struct
let cl_add_pr cl pr pr' =
Hpr.add cl.pr_table pr pr';
Hid.add cl.id_table pr.pr_name pr'.pr_name
Hid.add cl.id_table pr pr'
let rec cl_find_ts cl ts =
if not (Sid.mem ts.ts_name cl.id_local) then ts
......@@ -772,11 +741,10 @@ module Context = struct
let cl_trans_fmla cl f = f_s_map (cl_find_ts cl) (cl_find_ls cl) f
let cl_find_pr cl pr =
if not (Sid.mem pr.pr_name cl.id_local) then pr
if not (Sid.mem pr cl.id_local) then pr
else try Hpr.find cl.pr_table pr
with Not_found ->
let f' = cl_trans_fmla cl pr.pr_fmla in
let pr' = create_prop (id_dup pr.pr_name) f' in
let pr' = create_prop (id_dup pr) in
cl_add_pr cl pr pr';
pr'
......@@ -793,29 +761,16 @@ module Context = struct
in
(ts', def') :: acc
let cl_add_logic cl inst_ls acc = function
| Lfunction (ls, Some _) | Lpredicate (ls, Some _)
when Mls.mem ls inst_ls ->
raise (CannotInstantiate ls.