Skip to content

GitLab

why3
why3
Commit 3d355ed9 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files
Options

mutually inductive predicates, because we can

parent a0be4ad0
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 215 additions and 187 deletions
src/core/theory.ml
View file @ 3d355ed9
This diff is collapsed.
src/core/theory.mli
View file @ 3d355ed9
......@@ -21,6 +21,19 @@ open Ident
open Ty
open Term
(** Named propositions *)
type prop = private {
pr_name : ident;
pr_fmla : fmla;
}
module Spr : Set.S with type elt = prop
module Mpr : Map.S with type key = prop
module Hpr : Hashtbl.S with type key = prop
val create_prop : preid -> fmla -> prop
(** Declarations *)
(* type declaration *)
......@@ -51,7 +64,7 @@ val ps_defn_axiom : ps_defn -> fmla
(* inductive predicate declaration *)
type ind_decl = lsymbol * (ident * fmla) list
type ind_decl = lsymbol * prop list
(* proposition declaration *)
......@@ -60,7 +73,7 @@ type prop_kind =
| Plemma
| Pgoal
type prop_decl = prop_kind * ident * fmla
type prop_decl = prop_kind * prop
(** Context and Theory *)
......@@ -78,7 +91,7 @@ and namespace = private {
ns_ts : tysymbol Mnm.t; (* type symbols *)
ns_ls : lsymbol Mnm.t; (* logic symbols *)
ns_ns : namespace Mnm.t; (* inner namespaces *)
ns_pr : fmla Mnm.t; (* propositions *)
ns_pr : prop Mnm.t; (* propositions *)
}
and context = private {
......@@ -93,19 +106,19 @@ and decl = private {
}
and decl_node =
| Dtype of ty_decl list (* mutually recursive types *)
| Dlogic of logic_decl list (* mutually recursive functions/predicates *)
| Dind of ind_decl (* inductive predicate *)
| Dtype of ty_decl list (* recursive types *)
| Dlogic of logic_decl list (* recursive functions/predicates *)
| Dind of ind_decl list (* inductive predicates *)
| Dprop of prop_decl (* axiom / lemma / goal *)
| Duse of theory (* depend on a theory *)
| Dclone of (ident * ident) list (* replicate a theory *)
(** Declaration constructors *)
val create_type : ty_decl list -> decl
val create_logic : logic_decl list -> decl
val create_prop : prop_kind -> preid -> fmla -> decl
val create_ind : lsymbol -> (preid * fmla) list -> decl
val create_ty_decl : ty_decl list -> decl
val create_logic_decl : logic_decl list -> decl
val create_ind_decl : ind_decl list -> decl
val create_prop_decl : prop_kind -> prop -> decl
(* exceptions *)
......
src/core/transform.ml
View file @ 3d355ed9
......@@ -48,29 +48,29 @@ let memo f tag h x =
let d_tag d = d.d_tag
let ctxt_tag c = c.ctxt_tag
let t all clear clearf =
let t all clear clearf =
{all = all;
clear = match clear with
| None -> clearf
| Some clear -> (fun () -> clear ();clear ())
}
}
let fold_up ?clear f_fold v_empty =
let memo_t = Hashtbl.create 64 in
let rewind env todo =
List.fold_left
(fun env (desc,ctxt) ->
List.fold_left
(fun env (desc,ctxt) ->
let env = f_fold ctxt env desc in
Hashtbl.add memo_t ctxt.ctxt_tag env;
env) env todo in
let rec f todo ctxt =
let rec f todo ctxt =
match ctxt.ctxt_decls with
| None -> rewind v_empty todo
| Some (decls,ctxt2) ->
try
| Some (decls,ctxt2) ->
try
let env = Hashtbl.find memo_t ctxt2.ctxt_tag in
rewind env ((decls,ctxt)::todo)
with Not_found -> f ((decls,ctxt)::todo) ctxt2
with Not_found -> f ((decls,ctxt)::todo) ctxt2
in
t (f []) clear (fun () -> Hashtbl.clear memo_t)
......@@ -80,7 +80,7 @@ let fold_map_up ?clear f_fold v_empty =
let f_fold ctxt (env,ctxt2) decl = f_fold ctxt env ctxt2 decl in
translation (fold_up ?clear f_fold v_empty) snd
let elt ?clear f_elt =
let elt ?clear f_elt =
let memo_elt = Hashtbl.create 64 in
let f_elt _ () ctx x = (),
List.fold_left add_decl ctx (memo f_elt d_tag memo_elt x) in
......@@ -90,17 +90,17 @@ let elt ?clear f_elt =
let fold_bottom ?tag ?clear f_fold v_empty =
let tag_clear,tag_memo = match tag with
| None -> (fun () -> ()), (fun f v ctxt -> f v ctxt)
| Some tag_env ->
| Some tag_env ->
let memo_t = Hashtbl.create 64 in
(fun () -> Hashtbl.clear memo_t),(fun f v ctxt ->
try
try
Hashtbl.find memo_t (ctxt.ctxt_tag,(tag_env v : int))
with Not_found ->
let r = f v ctxt in
Hashtbl.add memo_t (ctxt.ctxt_tag,tag_env v) r;
r
) in
let rec f v ctxt =
let rec f v ctxt =
match ctxt.ctxt_decls with
| None -> v
| Some(d,ctxt2) ->
......@@ -115,10 +115,10 @@ let fold_map_bottom ?tag ?clear f_fold v_empty =
List.fold_left (List.fold_left add_decl) ctxt ldone in
let tag_clear,tag_memo = match tag with
| None -> (fun () -> ()), (fun f ldone v ctxt -> f ldone v ctxt)
| Some tag_env ->
| Some tag_env ->
let memo_t = Hashtbl.create 64 in
(fun () -> Hashtbl.clear memo_t),(fun f ldone v ctxt ->
try
try
let ctxt = Hashtbl.find memo_t (ctxt.ctxt_tag,tag_env v) in
rewind ldone ctxt
with Not_found ->
......@@ -126,7 +126,7 @@ let fold_map_bottom ?tag ?clear f_fold v_empty =
Hashtbl.add memo_t (ctxt.ctxt_tag,tag_env v) r;
r
) in
let rec f ldone v ctxt =
let rec f ldone v ctxt =
match ctxt.ctxt_decls with
| None -> rewind ldone ctxt
| Some(d,ctxt2) ->
......@@ -134,24 +134,25 @@ let fold_map_bottom ?tag ?clear f_fold v_empty =
tag_memo f (res::ldone) v ctxt2 in
let memo_t = Hashtbl.create 16 in
t (memo (f [] v_empty) ctxt_tag memo_t) clear (fun () -> tag_clear ();Hashtbl.clear memo_t)
let all ?clear f =
let memo_t = Hashtbl.create 16 in
t (memo f ctxt_tag memo_t) clear (fun () -> Hashtbl.clear memo_t)
(* Utils *)
(*type odecl =
(*type odecl =
| Otype of ty_decl
| Ologic of logic_decl
| Oprop of prop_decl
| Ouse of theory
| Oclone of (ident * ident) list*)
let elt_of_oelt ~ty ~logic ~prop ~use ~clone d =
let elt_of_oelt ~ty ~logic ~ind ~prop ~use ~clone d =
match d.d_node with
| Dtype l -> [create_type (List.map ty l)]
| Dlogic l -> [create_logic (List.map logic l)]
| Dtype l -> [create_ty_decl (List.map ty l)]
| Dlogic l -> [create_logic_decl (List.map logic l)]
| Dind l -> [create_ind_decl (List.map ind l)]
| Dprop p -> prop p
| Duse th -> use th
| Dclone c -> clone c
......@@ -159,4 +160,4 @@ let elt_of_oelt ~ty ~logic ~prop ~use ~clone d =
let fold_context_of_decl f ctxt env ctxt_done d =
let env,decls = f ctxt env d in
env,List.fold_left add_decl ctxt_done decls
src/core/transform.mli
View file @ 3d355ed9
......@@ -37,27 +37,27 @@ val clear : 'a t -> unit
(* the general tranformation only one memoisation is performed at the
beginning *)
val all :
val all :
?clear:(unit -> unit) ->
(context -> 'a) -> 'a t
(* map the element of the list from the first to the last. only one
memoisation is performed at the beginning. But if a tag function is
given a memoisation is performed at each step *)
val fold_map_bottom :
val fold_map_bottom :
?tag:('a -> int) ->
?clear:(unit -> unit) ->
(context -> 'a -> decl -> 'a * decl list) -> 'a -> context t
(* map the element of the list from the last to the first.
A memoisation is performed at each step *)
val fold_map_up :
val fold_map_up :
?clear:(unit -> unit) ->
(context -> 'a -> context -> decl -> ('a * context)) -> 'a -> context t
(* map the element of the list without an environnment.
A memoisation is performed at each step, and for each elements *)
val elt :
val elt :
?clear:(unit -> unit) ->
(decl -> decl list) -> context t
......@@ -74,7 +74,7 @@ val fold_up :
(*type odecl =
(*type odecl =
| Otype of ty_decl
| Ologic of logic_decl
| Oprop of prop_decl
......@@ -84,6 +84,7 @@ val fold_up :
val elt_of_oelt :
ty:(ty_decl -> ty_decl) ->
logic:(logic_decl -> logic_decl) ->
ind:(ind_decl -> ind_decl) ->
prop:(prop_decl -> decl list) ->
use:(theory -> decl list) ->
clone:((ident * ident) list -> decl list) ->
......
src/output/alt_ergo.ml
View file @ 3d355ed9
......@@ -128,11 +128,13 @@ let print_decl fmt d = match d.d_node with
print_list newline print_logic_decl fmt dl
| Dind _ ->
assert false
| Dprop (Paxiom, id, f) ->
fprintf fmt "@[<hov 2>axiom %a :@ %a@]@\n" print_ident id print_fmla f
| Dprop (Pgoal, id, f) ->
fprintf fmt "@[<hov 2>goal %a :@ %a@]@\n" print_ident id print_fmla f
| Dprop (Plemma, _, _) ->
| Dprop (Paxiom, pr) ->
fprintf fmt "@[<hov 2>axiom %a :@ %a@]@\n"
print_ident pr.pr_name print_fmla pr.pr_fmla
| Dprop (Pgoal, pr) ->
fprintf fmt "@[<hov 2>goal %a :@ %a@]@\n"
print_ident pr.pr_name print_fmla pr.pr_fmla
| Dprop (Plemma, _) ->
assert false
| Duse _ | Dclone _ ->
()
......
src/output/why3.ml
View file @ 3d355ed9
......@@ -276,8 +276,16 @@ let print_logic_decl fmt = function
let print_logic_decl fmt d = print_logic_decl fmt d; forget_tvs ()
let print_indbr fmt (id,f) =
fprintf fmt "@[<hov 4>| %a : %a@]" print_uc id print_fmla f
let print_prop fmt pr =
fprintf fmt "%a : %a" print_uc pr.pr_name print_fmla pr.pr_fmla
let print_ind fmt pr = fprintf fmt "@[<hov 4>| %a@]" print_prop pr
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;
forget_tvs ()
let print_pkind fmt = function
| Paxiom -> fprintf fmt "axiom"
......@@ -288,21 +296,16 @@ let print_inst fmt (id1,id2) =
fprintf fmt "%a = %a" print_id id1 print_id id2
let print_decl fmt d = match d.d_node with
| Dtype tl -> print_list newline2 print_type_decl fmt tl
| Dtype tl -> print_list newline2 print_type_decl fmt tl
| Dlogic ll -> print_list newline2 print_logic_decl fmt ll
| Dind (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_indbr) bl;
forget_tvs ()
| Dprop (k,id,fmla) ->
fprintf fmt "@[<hov 2>%a %a :@ %a@]"
print_pkind k print_uc id print_fmla fmla;
| Dind il -> print_list newline2 print_ind_decl fmt il
| Dprop (k,pr) ->
fprintf fmt "@[<hov 2>%a %a@]" print_pkind k print_prop pr;
forget_tvs ()
| Duse th ->
fprintf fmt "@[<hov 2>use export %a@]" print_id th.th_name
fprintf fmt "@[<hov 2>(* use export %a *)@]" print_id th.th_name
| Dclone inst ->
fprintf fmt "@[<hov 2>(* clone with@ %a *)@]"
fprintf fmt "@[<hov 2>(* clone with %a *)@]"
(print_list comma print_inst) inst
(* let print_decl fmt d = fprintf fmt "%a@\n" print_decl d *)
......
src/parser/typing.ml
View file @ 3d355ed9
......@@ -181,7 +181,7 @@ let term_expected_type ~loc ty1 ty2 =
"@[This term has type %a@ but is expected to have type@ %a@]"
print_dty ty1 print_dty ty2
let create_type_var =
let create_ty_decl_var =
let t = ref 0 in
fun ?loc ~user tv ->
incr t;
......@@ -237,7 +237,7 @@ let find_user_type_var x env =
with Not_found ->
(* TODO: shouldn't we localize this ident? *)
let v = create_tvsymbol (id_fresh x) in
let v = create_type_var ~user:true v in
let v = create_ty_decl_var ~user:true v in
Hashtbl.add env.utyvars x v;
v
......@@ -249,7 +249,7 @@ let find_type_var ~loc env tv =
try
Htv.find env tv
with Not_found ->
let v = create_type_var ~loc ~user:false tv in
let v = create_ty_decl_var ~loc ~user:false tv in
Htv.add env tv v;
v
......@@ -433,11 +433,11 @@ let rec dpat env pat =
and dpat_node loc env = function
| PPpwild ->
let tv = create_tvsymbol (id_user "a" loc) in
let ty = Tyvar (create_type_var ~loc ~user:false tv) in
let ty = Tyvar (create_ty_decl_var ~loc ~user:false tv) in
env, Pwild, ty
| PPpvar {id=x} ->
let tv = create_tvsymbol (id_user "a" loc) in
let ty = Tyvar (create_type_var ~loc ~user:false tv) in
let ty = Tyvar (create_ty_decl_var ~loc ~user:false tv) in
let env = { env with dvars = M.add x ty env.dvars } in
env, Pvar x, ty
| PPpapp (x, pl) ->
......@@ -516,7 +516,7 @@ and dterm_node loc env = function
let ty = e1.dt_ty in
let tb = (* the type of all branches *)
let tv = create_tvsymbol (id_user "a" loc) in
Tyvar (create_type_var ~loc ~user:false tv)
Tyvar (create_ty_decl_var ~loc ~user:false tv)
in
let branch (pat, e) =
let loc = pat.pat_loc in
......@@ -605,7 +605,7 @@ and dfmla env e = match e.pp_desc with
let f1 = dfmla env f1 in
Fnamed (x, f1)
| PPvar x ->
Fvar (find_prop x env.th)
Fvar (find_prop x env.th).pr_fmla
| PPconst _ | PPcast _ ->
error ~loc:e.pp_loc PredicateExpected
......@@ -788,7 +788,7 @@ let add_types loc dl th =
let tsl =
M.fold (fun x _ tsl -> let ts = visit x in (ts, Tabstract) :: tsl) def []
in
add_decl th (create_type tsl)
add_decl th (create_ty_decl tsl)
in
let decl d =
let ts, th' = match Hashtbl.find tysymbols d.td_ident.id with
......@@ -799,7 +799,7 @@ let add_types loc dl th =
let vars = th'.utyvars in
List.iter
(fun v ->
Hashtbl.add vars v.id_short (create_type_var ~user:true v))
Hashtbl.add vars v.id_short (create_ty_decl_var ~user:true v))
ts.ts_args;
ts, th'
in
......@@ -818,7 +818,7 @@ let add_types loc dl th =
ts, d
in
let dl = List.map decl dl in
add_decl th (create_type dl)
add_decl th (create_ty_decl dl)
let env_of_vsymbol_list vl =
List.fold_left (fun env v -> M.add v.vs_name.id_short v env) M.empty vl
......@@ -841,12 +841,12 @@ let add_logics loc dl th =
| None -> (* predicate *)
let ps = create_psymbol v pl in
Hashtbl.add psymbols id ps;
add_decl th (create_logic [Lpredicate (ps, None)])
add_decl th (create_logic_decl [Lpredicate (ps, None)])
| Some t -> (* function *)
let t = type_ty (None, t) in
let fs = create_fsymbol v pl t in
Hashtbl.add fsymbols id fs;
add_decl th (create_logic [Lfunction (fs, None)])
add_decl th (create_logic_decl [Lfunction (fs, None)])
in
let th' = List.fold_left create_symbol th dl in
(* 2. then type-check all definitions *)
......@@ -900,7 +900,7 @@ let add_logics loc dl th =
Lfunction (fs, defn)
in
let dl = List.map type_decl dl in
add_decl th (create_logic dl)
add_decl th (create_logic_decl dl)
let term env t =
......@@ -916,7 +916,7 @@ let fmla env f =
let add_prop k loc s f th =
let f = fmla th f in
try
add_decl th (create_prop k (id_user s.id loc) f)
add_decl th (create_prop_decl k (create_prop (id_user s.id loc) f))
with ClashSymbol _ ->
error ~loc (Clash s.id)
......@@ -991,15 +991,15 @@ let add_inductive loc id tyl cl th =
let denv = create_denv th in
let pl = List.map (fun ty -> ty_of_dty (dty denv ty)) tyl in
let ps = create_psymbol (id_user id.id loc) pl in
let th' = add_decl th (create_logic [Lpredicate (ps, None)]) in
let th' = add_decl th (create_logic_decl [Lpredicate (ps, None)]) in
let clause (id, f) =
let loc = f.pp_loc in
let f' = fmla th' f in
check_clausal_form loc ps f';
id_user id.id id.id_loc, f'
create_prop (id_user id.id id.id_loc) f'
in
let cl = List.map clause cl in
add_decl th (create_ind ps cl)
add_decl th (create_ind_decl [(ps,cl)])
let find_in_loadpath env f =
let rec find c lp = match lp, c with
......
src/pretty.ml
View file @ 3d355ed9
......@@ -156,19 +156,23 @@ let print_logic_decl fmt = function
fprintf fmt "@[<hov 2>logic %a :@ %a@]" print_ident ps.ls_name
print_fmla (ps_defn_axiom fd)
let print_ind_decl fmt (ps,_) =
fprintf fmt "@[<hov 2>inductive %a ...@]" print_ident ps.ls_name
let print_decl fmt d = match d.d_node with
| Dtype tl ->
fprintf fmt "@[<hov>%a@ (* *)@]" (print_list newline print_ty_decl) tl
| Dlogic ldl ->
fprintf fmt "@[<hov>%a@ (* *)@]"
(print_list newline print_logic_decl) ldl
| Dprop (k,id,fmla) ->
| Dind idl ->
fprintf fmt "@[<hov>%a@ (* *)@]"
(print_list newline print_ind_decl) idl
| Dprop (k,pr) ->
fprintf fmt "%s %a :@ %a@\n"
(match k with Paxiom -> "axiom" | Pgoal -> "goal" | Plemma -> "lemma")
print_ident id
print_fmla fmla
| Dind (ps, fl) ->
fprintf fmt "@[<hov 2>inductive %a ...@]" print_ident ps.ls_name
print_ident pr.pr_name
print_fmla pr.pr_fmla
| Duse u -> fprintf fmt "use export %a@\n" print_ident u.th_name
| Dclone il -> fprintf fmt "(*@[<hov 2>clone export _ with %a@]@\n"
(print_list comma (print_pair_delim nothing nothing equal print_ident print_ident)) il
......
src/transform/flatten.ml
View file @ 3d355ed9
......@@ -3,8 +3,8 @@ open Theory
let elt a =
let rec aux first_level acc d = match first_level, d.d_node with
| _,Duse t -> Context.ctxt_fold (aux false) acc t.th_ctxt
| false,Dprop (Pgoal,_,_) -> acc
| false,Dprop (Plemma,i,f) -> (create_prop Paxiom (Ident.id_dup i) f)::acc
| false,Dprop (Pgoal,_) -> acc
| false,Dprop (Plemma,pr) -> create_prop_decl Paxiom pr::acc
| _ -> d::acc
in
let r = (aux true [] a) in
......
src/transform/inlining.ml
View file @ 3d355ed9
......@@ -59,7 +59,7 @@ let fold isnotinlinedt isnotinlinedf _ env ctxt d =
if t_s_any ffalse ((==) fs) t || isnotinlinedt t
then env,
add_decl ctxt
(create_logic [Lfunction(fs,
(create_logic_decl [Lfunction(fs,
Some (make_fs_defn fs vs t))])
else {env with fs = Mls.add fs (vs,t) env.fs},ctxt
| Lpredicate (ps,None) -> env,add_decl ctxt d
......@@ -69,15 +69,16 @@ let fold isnotinlinedt isnotinlinedf _ env ctxt d =
if f_s_any ffalse ((==) ps) f || isnotinlinedf f
then env,
add_decl ctxt
(create_logic [Lpredicate(ps,Some (make_ps_defn ps vs f))])
(create_logic_decl [Lpredicate(ps,Some (make_ps_defn ps vs f))])
else {env with ps = Mls.add ps (vs,f) env.ps},ctxt
end
| Dind (ps,fmlal) ->
let fmlal = List.map
(fun (id,fmla) -> id_dup id,replacep env fmla) fmlal in
env,add_decl ctxt (create_ind ps fmlal)
| Dind dl ->
env, add_decl ctxt (create_ind_decl
(List.map (fun (ps,fmlal) -> ps, List.map (fun pr ->
create_prop (id_dup pr.pr_name) (replacep env pr.pr_fmla))
fmlal) dl))
| Dlogic dl -> env,
add_decl ctxt (create_logic
add_decl ctxt (create_logic_decl
(List.map
(function
| Lfunction (fs,None) as a -> a
......@@ -92,8 +93,8 @@ let fold isnotinlinedt isnotinlinedf _ env ctxt d =
Lpredicate (ps,Some (make_ps_defn ps vs t))
) dl))
| Dtype dl -> env,add_decl ctxt d
| Dprop (k,i,fmla) -> env,add_decl ctxt (create_prop k (id_dup i)
(replacep env fmla))
| Dprop (k,pr) -> env,add_decl ctxt (create_prop_decl k
(create_prop (id_dup pr.pr_name) (replacep env pr.pr_fmla)))
| Duse _ | Dclone _ -> env,add_decl ctxt d
let t ~isnotinlinedt ~isnotinlinedf =
......
src/transform/simplify_recursive_definition.ml
View file @ 3d355ed9
......@@ -110,7 +110,7 @@ let elt d =
f_s_fold tyoccurences loccurences Sid.empty fd in
Mid.add ps.ls_name s acc) Mid.empty l in
let l = connexe m in
List.map (fun e -> create_logic (List.map (Hid.find mem) e)) l
List.map (fun e -> create_logic_decl (List.map (Hid.find mem) e)) l
| Dtype l ->
let mem = Hid.create 16 in
List.iter (fun ((ts,_) as a) -> Hid.add mem ts.ts_name a) l;
......@@ -136,8 +136,9 @@ let elt d =
) Sid.empty l in
Mid.add ts.ts_name s acc) Mid.empty l in
let l = connexe m in
List.map (fun e -> create_type (List.map (Hid.find mem) e)) l
| Dprop _ | Dind _ | Dclone _ | Duse _ -> [d]
List.map (fun e -> create_ty_decl (List.map (Hid.find mem) e)) l
| Dind _ -> [d] (* TODO *)
| Dprop _ | Dclone _ | Duse _ -> [d]
let elt d =
let r = elt d in
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment