Commit 3d355ed9 authored by Andrei Paskevich's avatar Andrei Paskevich

mutually inductive predicates, because we can

parent a0be4ad0
This diff is collapsed.
......@@ -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 *)
......
......@@ -148,10 +148,11 @@ let all ?clear f =
| 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
......
......@@ -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) ->
......
......@@ -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 _ ->
()
......
......@@ -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"
......@@ -290,19 +298,14 @@ let print_inst fmt (id1,id2) =
let print_decl fmt d = match d.d_node with
| 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 *)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 =
......
......@@ -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