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 ...@@ -21,6 +21,19 @@ open Ident
open Ty open Ty
open Term 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 *) (** Declarations *)
(* type declaration *) (* type declaration *)
...@@ -51,7 +64,7 @@ val ps_defn_axiom : ps_defn -> fmla ...@@ -51,7 +64,7 @@ val ps_defn_axiom : ps_defn -> fmla
(* inductive predicate declaration *) (* inductive predicate declaration *)
type ind_decl = lsymbol * (ident * fmla) list type ind_decl = lsymbol * prop list
(* proposition declaration *) (* proposition declaration *)
...@@ -60,7 +73,7 @@ type prop_kind = ...@@ -60,7 +73,7 @@ type prop_kind =
| Plemma | Plemma
| Pgoal | Pgoal
type prop_decl = prop_kind * ident * fmla type prop_decl = prop_kind * prop
(** Context and Theory *) (** Context and Theory *)
...@@ -78,7 +91,7 @@ and namespace = private { ...@@ -78,7 +91,7 @@ and namespace = private {
ns_ts : tysymbol Mnm.t; (* type symbols *) ns_ts : tysymbol Mnm.t; (* type symbols *)
ns_ls : lsymbol Mnm.t; (* logic symbols *) ns_ls : lsymbol Mnm.t; (* logic symbols *)
ns_ns : namespace Mnm.t; (* inner namespaces *) ns_ns : namespace Mnm.t; (* inner namespaces *)
ns_pr : fmla Mnm.t; (* propositions *) ns_pr : prop Mnm.t; (* propositions *)
} }
and context = private { and context = private {
...@@ -93,19 +106,19 @@ and decl = private { ...@@ -93,19 +106,19 @@ and decl = private {
} }
and decl_node = and decl_node =
| Dtype of ty_decl list (* mutually recursive types *) | Dtype of ty_decl list (* recursive types *)
| Dlogic of logic_decl list (* mutually recursive functions/predicates *) | Dlogic of logic_decl list (* recursive functions/predicates *)
| Dind of ind_decl (* inductive predicate *) | Dind of ind_decl list (* inductive predicates *)
| Dprop of prop_decl (* axiom / lemma / goal *) | Dprop of prop_decl (* axiom / lemma / goal *)
| Duse of theory (* depend on a theory *) | Duse of theory (* depend on a theory *)
| Dclone of (ident * ident) list (* replicate a theory *) | Dclone of (ident * ident) list (* replicate a theory *)
(** Declaration constructors *) (** Declaration constructors *)
val create_type : ty_decl list -> decl val create_ty_decl : ty_decl list -> decl
val create_logic : logic_decl list -> decl val create_logic_decl : logic_decl list -> decl
val create_prop : prop_kind -> preid -> fmla -> decl val create_ind_decl : ind_decl list -> decl
val create_ind : lsymbol -> (preid * fmla) list -> decl val create_prop_decl : prop_kind -> prop -> decl
(* exceptions *) (* exceptions *)
......
...@@ -48,29 +48,29 @@ let memo f tag h x = ...@@ -48,29 +48,29 @@ let memo f tag h x =
let d_tag d = d.d_tag let d_tag d = d.d_tag
let ctxt_tag c = c.ctxt_tag let ctxt_tag c = c.ctxt_tag
let t all clear clearf = let t all clear clearf =
{all = all; {all = all;
clear = match clear with clear = match clear with
| None -> clearf | None -> clearf
| Some clear -> (fun () -> clear ();clear ()) | Some clear -> (fun () -> clear ();clear ())
} }
let fold_up ?clear f_fold v_empty = let fold_up ?clear f_fold v_empty =
let memo_t = Hashtbl.create 64 in let memo_t = Hashtbl.create 64 in
let rewind env todo = let rewind env todo =
List.fold_left List.fold_left
(fun env (desc,ctxt) -> (fun env (desc,ctxt) ->
let env = f_fold ctxt env desc in let env = f_fold ctxt env desc in
Hashtbl.add memo_t ctxt.ctxt_tag env; Hashtbl.add memo_t ctxt.ctxt_tag env;
env) env todo in env) env todo in
let rec f todo ctxt = let rec f todo ctxt =
match ctxt.ctxt_decls with match ctxt.ctxt_decls with
| None -> rewind v_empty todo | None -> rewind v_empty todo
| Some (decls,ctxt2) -> | Some (decls,ctxt2) ->
try try
let env = Hashtbl.find memo_t ctxt2.ctxt_tag in let env = Hashtbl.find memo_t ctxt2.ctxt_tag in
rewind env ((decls,ctxt)::todo) rewind env ((decls,ctxt)::todo)
with Not_found -> f ((decls,ctxt)::todo) ctxt2 with Not_found -> f ((decls,ctxt)::todo) ctxt2
in in
t (f []) clear (fun () -> Hashtbl.clear memo_t) t (f []) clear (fun () -> Hashtbl.clear memo_t)
...@@ -80,7 +80,7 @@ let fold_map_up ?clear f_fold v_empty = ...@@ -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 let f_fold ctxt (env,ctxt2) decl = f_fold ctxt env ctxt2 decl in
translation (fold_up ?clear f_fold v_empty) snd 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 memo_elt = Hashtbl.create 64 in
let f_elt _ () ctx x = (), let f_elt _ () ctx x = (),
List.fold_left add_decl ctx (memo f_elt d_tag memo_elt x) in List.fold_left add_decl ctx (memo f_elt d_tag memo_elt x) in
...@@ -90,17 +90,17 @@ let elt ?clear f_elt = ...@@ -90,17 +90,17 @@ let elt ?clear f_elt =
let fold_bottom ?tag ?clear f_fold v_empty = let fold_bottom ?tag ?clear f_fold v_empty =
let tag_clear,tag_memo = match tag with let tag_clear,tag_memo = match tag with
| None -> (fun () -> ()), (fun f v ctxt -> f v ctxt) | None -> (fun () -> ()), (fun f v ctxt -> f v ctxt)
| Some tag_env -> | Some tag_env ->
let memo_t = Hashtbl.create 64 in let memo_t = Hashtbl.create 64 in
(fun () -> Hashtbl.clear memo_t),(fun f v ctxt -> (fun () -> Hashtbl.clear memo_t),(fun f v ctxt ->
try try
Hashtbl.find memo_t (ctxt.ctxt_tag,(tag_env v : int)) Hashtbl.find memo_t (ctxt.ctxt_tag,(tag_env v : int))
with Not_found -> with Not_found ->
let r = f v ctxt in let r = f v ctxt in
Hashtbl.add memo_t (ctxt.ctxt_tag,tag_env v) r; Hashtbl.add memo_t (ctxt.ctxt_tag,tag_env v) r;
r r
) in ) in
let rec f v ctxt = let rec f v ctxt =
match ctxt.ctxt_decls with match ctxt.ctxt_decls with
| None -> v | None -> v
| Some(d,ctxt2) -> | Some(d,ctxt2) ->
...@@ -115,10 +115,10 @@ let fold_map_bottom ?tag ?clear f_fold v_empty = ...@@ -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 List.fold_left (List.fold_left add_decl) ctxt ldone in
let tag_clear,tag_memo = match tag with let tag_clear,tag_memo = match tag with
| None -> (fun () -> ()), (fun f ldone v ctxt -> f ldone v ctxt) | None -> (fun () -> ()), (fun f ldone v ctxt -> f ldone v ctxt)
| Some tag_env -> | Some tag_env ->
let memo_t = Hashtbl.create 64 in let memo_t = Hashtbl.create 64 in
(fun () -> Hashtbl.clear memo_t),(fun f ldone v ctxt -> (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 let ctxt = Hashtbl.find memo_t (ctxt.ctxt_tag,tag_env v) in
rewind ldone ctxt rewind ldone ctxt
with Not_found -> with Not_found ->
...@@ -126,7 +126,7 @@ let fold_map_bottom ?tag ?clear f_fold v_empty = ...@@ -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; Hashtbl.add memo_t (ctxt.ctxt_tag,tag_env v) r;
r r
) in ) in
let rec f ldone v ctxt = let rec f ldone v ctxt =
match ctxt.ctxt_decls with match ctxt.ctxt_decls with
| None -> rewind ldone ctxt | None -> rewind ldone ctxt
| Some(d,ctxt2) -> | Some(d,ctxt2) ->
...@@ -134,24 +134,25 @@ let fold_map_bottom ?tag ?clear f_fold v_empty = ...@@ -134,24 +134,25 @@ let fold_map_bottom ?tag ?clear f_fold v_empty =
tag_memo f (res::ldone) v ctxt2 in tag_memo f (res::ldone) v ctxt2 in
let memo_t = Hashtbl.create 16 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) t (memo (f [] v_empty) ctxt_tag memo_t) clear (fun () -> tag_clear ();Hashtbl.clear memo_t)
let all ?clear f = let all ?clear f =
let memo_t = Hashtbl.create 16 in let memo_t = Hashtbl.create 16 in
t (memo f ctxt_tag memo_t) clear (fun () -> Hashtbl.clear memo_t) t (memo f ctxt_tag memo_t) clear (fun () -> Hashtbl.clear memo_t)
(* Utils *) (* Utils *)
(*type odecl = (*type odecl =
| Otype of ty_decl | Otype of ty_decl
| Ologic of logic_decl | Ologic of logic_decl
| Oprop of prop_decl | Oprop of prop_decl
| Ouse of theory | Ouse of theory
| Oclone of (ident * ident) list*) | 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 match d.d_node with
| Dtype l -> [create_type (List.map ty l)] | Dtype l -> [create_ty_decl (List.map ty l)]
| Dlogic l -> [create_logic (List.map logic l)] | Dlogic l -> [create_logic_decl (List.map logic l)]
| Dind l -> [create_ind_decl (List.map ind l)]
| Dprop p -> prop p | Dprop p -> prop p
| Duse th -> use th | Duse th -> use th
| Dclone c -> clone c | Dclone c -> clone c
...@@ -159,4 +160,4 @@ let elt_of_oelt ~ty ~logic ~prop ~use ~clone d = ...@@ -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 fold_context_of_decl f ctxt env ctxt_done d =
let env,decls = f ctxt env d in let env,decls = f ctxt env d in
env,List.fold_left add_decl ctxt_done decls env,List.fold_left add_decl ctxt_done decls
...@@ -37,27 +37,27 @@ val clear : 'a t -> unit ...@@ -37,27 +37,27 @@ val clear : 'a t -> unit
(* the general tranformation only one memoisation is performed at the (* the general tranformation only one memoisation is performed at the
beginning *) beginning *)
val all : val all :
?clear:(unit -> unit) -> ?clear:(unit -> unit) ->
(context -> 'a) -> 'a t (context -> 'a) -> 'a t
(* map the element of the list from the first to the last. only one (* 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 memoisation is performed at the beginning. But if a tag function is
given a memoisation is performed at each step *) given a memoisation is performed at each step *)
val fold_map_bottom : val fold_map_bottom :
?tag:('a -> int) -> ?tag:('a -> int) ->
?clear:(unit -> unit) -> ?clear:(unit -> unit) ->
(context -> 'a -> decl -> 'a * decl list) -> 'a -> context t (context -> 'a -> decl -> 'a * decl list) -> 'a -> context t
(* map the element of the list from the last to the first. (* map the element of the list from the last to the first.
A memoisation is performed at each step *) A memoisation is performed at each step *)
val fold_map_up : val fold_map_up :
?clear:(unit -> unit) -> ?clear:(unit -> unit) ->
(context -> 'a -> context -> decl -> ('a * context)) -> 'a -> context t (context -> 'a -> context -> decl -> ('a * context)) -> 'a -> context t
(* map the element of the list without an environnment. (* map the element of the list without an environnment.
A memoisation is performed at each step, and for each elements *) A memoisation is performed at each step, and for each elements *)
val elt : val elt :
?clear:(unit -> unit) -> ?clear:(unit -> unit) ->
(decl -> decl list) -> context t (decl -> decl list) -> context t
...@@ -74,7 +74,7 @@ val fold_up : ...@@ -74,7 +74,7 @@ val fold_up :
(*type odecl = (*type odecl =
| Otype of ty_decl | Otype of ty_decl
| Ologic of logic_decl | Ologic of logic_decl
| Oprop of prop_decl | Oprop of prop_decl
...@@ -84,6 +84,7 @@ val fold_up : ...@@ -84,6 +84,7 @@ val fold_up :
val elt_of_oelt : val elt_of_oelt :
ty:(ty_decl -> ty_decl) -> ty:(ty_decl -> ty_decl) ->
logic:(logic_decl -> logic_decl) -> logic:(logic_decl -> logic_decl) ->
ind:(ind_decl -> ind_decl) ->
prop:(prop_decl -> decl list) -> prop:(prop_decl -> decl list) ->
use:(theory -> decl list) -> use:(theory -> decl list) ->
clone:((ident * ident) list -> decl list) -> clone:((ident * ident) list -> decl list) ->
......
...@@ -128,11 +128,13 @@ let print_decl fmt d = match d.d_node with ...@@ -128,11 +128,13 @@ let print_decl fmt d = match d.d_node with
print_list newline print_logic_decl fmt dl print_list newline print_logic_decl fmt dl
| Dind _ -> | Dind _ ->
assert false assert false
| Dprop (Paxiom, id, f) -> | Dprop (Paxiom, pr) ->
fprintf fmt "@[<hov 2>axiom %a :@ %a@]@\n" print_ident id print_fmla f fprintf fmt "@[<hov 2>axiom %a :@ %a@]@\n"
| Dprop (Pgoal, id, f) -> print_ident pr.pr_name print_fmla pr.pr_fmla
fprintf fmt "@[<hov 2>goal %a :@ %a@]@\n" print_ident id print_fmla f | Dprop (Pgoal, pr) ->
| Dprop (Plemma, _, _) -> fprintf fmt "@[<hov 2>goal %a :@ %a@]@\n"
print_ident pr.pr_name print_fmla pr.pr_fmla
| Dprop (Plemma, _) ->
assert false assert false
| Duse _ | Dclone _ -> | Duse _ | Dclone _ ->
() ()
......
...@@ -276,8 +276,16 @@ let print_logic_decl fmt = function ...@@ -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_logic_decl fmt d = print_logic_decl fmt d; forget_tvs ()
let print_indbr fmt (id,f) = let print_prop fmt pr =
fprintf fmt "@[<hov 4>| %a : %a@]" print_uc id print_fmla f 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 let print_pkind fmt = function
| Paxiom -> fprintf fmt "axiom" | Paxiom -> fprintf fmt "axiom"
...@@ -288,21 +296,16 @@ let print_inst fmt (id1,id2) = ...@@ -288,21 +296,16 @@ let print_inst fmt (id1,id2) =
fprintf fmt "%a = %a" print_id id1 print_id id2 fprintf fmt "%a = %a" print_id id1 print_id id2
let print_decl fmt d = match d.d_node with 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 | Dlogic ll -> print_list newline2 print_logic_decl fmt ll
| Dind (ps,bl) -> | Dind il -> print_list newline2 print_ind_decl fmt il
fprintf fmt "@[<hov 2>inductive %a%a =@ @[<hov>%a@]@]" | Dprop (k,pr) ->
print_ls ps (print_paren_l print_ty) ps.ls_args fprintf fmt "@[<hov 2>%a %a@]" print_pkind k print_prop pr;
(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;
forget_tvs () forget_tvs ()
| Duse th -> | 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 -> | Dclone inst ->
fprintf fmt "@[<hov 2>(* clone with@ %a *)@]" fprintf fmt "@[<hov 2>(* clone with %a *)@]"
(print_list comma print_inst) inst (print_list comma print_inst) inst
(* let print_decl fmt d = fprintf fmt "%a@\n" print_decl d *) (* let print_decl fmt d = fprintf fmt "%a@\n" print_decl d *)
......
...@@ -181,7 +181,7 @@ let term_expected_type ~loc ty1 ty2 = ...@@ -181,7 +181,7 @@ let term_expected_type ~loc ty1 ty2 =
"@[This term has type %a@ but is expected to have type@ %a@]" "@[This term has type %a@ but is expected to have type@ %a@]"
print_dty ty1 print_dty ty2 print_dty ty1 print_dty ty2
let create_type_var = let create_ty_decl_var =
let t = ref 0 in let t = ref 0 in
fun ?loc ~user tv -> fun ?loc ~user tv ->
incr t; incr t;
...@@ -237,7 +237,7 @@ let find_user_type_var x env = ...@@ -237,7 +237,7 @@ let find_user_type_var x env =
with Not_found -> with Not_found ->
(* TODO: shouldn't we localize this ident? *) (* TODO: shouldn't we localize this ident? *)
let v = create_tvsymbol (id_fresh x) in 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; Hashtbl.add env.utyvars x v;
v v
...@@ -249,7 +249,7 @@ let find_type_var ~loc env tv = ...@@ -249,7 +249,7 @@ let find_type_var ~loc env tv =
try try
Htv.find env tv Htv.find env tv
with Not_found -> 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; Htv.add env tv v;
v v
...@@ -433,11 +433,11 @@ let rec dpat env pat = ...@@ -433,11 +433,11 @@ let rec dpat env pat =
and dpat_node loc env = function and dpat_node loc env = function
| PPpwild -> | PPpwild ->
let tv = create_tvsymbol (id_user "a" loc) in 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 env, Pwild, ty
| PPpvar {id=x} -> | PPpvar {id=x} ->
let tv = create_tvsymbol (id_user "a" loc) in 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 let env = { env with dvars = M.add x ty env.dvars } in
env, Pvar x, ty env, Pvar x, ty
| PPpapp (x, pl) -> | PPpapp (x, pl) ->
...@@ -516,7 +516,7 @@ and dterm_node loc env = function ...@@ -516,7 +516,7 @@ and dterm_node loc env = function
let ty = e1.dt_ty in let ty = e1.dt_ty in
let tb = (* the type of all branches *) let tb = (* the type of all branches *)
let tv = create_tvsymbol (id_user "a" loc) in 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 in
let branch (pat, e) = let branch (pat, e) =
let loc = pat.pat_loc in let loc = pat.pat_loc in
...@@ -605,7 +605,7 @@ and dfmla env e = match e.pp_desc with ...@@ -605,7 +605,7 @@ and dfmla env e = match e.pp_desc with
let f1 = dfmla env f1 in let f1 = dfmla env f1 in
Fnamed (x, f1) Fnamed (x, f1)
| PPvar x -> | PPvar x ->
Fvar (find_prop x env.th) Fvar (find_prop x env.th).pr_fmla
| PPconst _ | PPcast _ -> | PPconst _ | PPcast _ ->
error ~loc:e.pp_loc PredicateExpected error ~loc:e.pp_loc PredicateExpected
...@@ -788,7 +788,7 @@ let add_types loc dl th = ...@@ -788,7 +788,7 @@ let add_types loc dl th =
let tsl = let tsl =
M.fold (fun x _ tsl -> let ts = visit x in (ts, Tabstract) :: tsl) def [] M.fold (fun x _ tsl -> let ts = visit x in (ts, Tabstract) :: tsl) def []
in in
add_decl th (create_type tsl) add_decl th (create_ty_decl tsl)
in in
let decl d = let decl d =
let ts, th' = match Hashtbl.find tysymbols d.td_ident.id with let ts, th' = match Hashtbl.find tysymbols d.td_ident.id with
...@@ -799,7 +799,7 @@ let add_types loc dl th = ...@@ -799,7 +799,7 @@ let add_types loc dl th =
let vars = th'.utyvars in let vars = th'.utyvars in
List.iter List.iter
(fun v -> (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.ts_args;
ts, th' ts, th'
in in
...@@ -818,7 +818,7 @@ let add_types loc dl th = ...@@ -818,7 +818,7 @@ let add_types loc dl th =
ts, d ts, d
in in
let dl = List.map decl dl 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 = let env_of_vsymbol_list vl =
List.fold_left (fun env v -> M.add v.vs_name.id_short v env) M.empty 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 = ...@@ -841,12 +841,12 @@ let add_logics loc dl th =
| None -> (* predicate *) | None -> (* predicate *)
let ps = create_psymbol v pl in let ps = create_psymbol v pl in
Hashtbl.add psymbols id ps; 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 *) | Some t -> (* function *)
let t = type_ty (None, t) in let t = type_ty (None, t) in
let fs = create_fsymbol v pl t in let fs = create_fsymbol v pl t in
Hashtbl.add fsymbols id fs; Hashtbl.add fsymbols id fs;
add_decl th (create_logic [Lfunction (fs, None)]) add_decl th (create_logic_decl [Lfunction (fs, None)])
in in
let th' = List.fold_left create_symbol th dl in let th' = List.fold_left create_symbol th dl in
(* 2. then type-check all definitions *) (* 2. then type-check all definitions *)
...@@ -900,7 +900,7 @@ let add_logics loc dl th = ...@@ -900,7 +900,7 @@ let add_logics loc dl th =
Lfunction (fs, defn) Lfunction (fs, defn)
in in
let dl = List.map type_decl dl 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 = let term env t =
...@@ -916,7 +916,7 @@ let fmla env f = ...@@ -916,7 +916,7 @@ let fmla env f =
let add_prop k loc s f th = let add_prop k loc s f th =
let f = fmla th f in let f = fmla th f in
try 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 _ -> with ClashSymbol _ ->
error ~loc (Clash s.id) error ~loc (Clash s.id)
...@@ -991,15 +991,15 @@ let add_inductive loc id tyl cl th = ...@@ -991,15 +991,15 @@ let add_inductive loc id tyl cl th =
let denv = create_denv th in let denv = create_denv th in
let pl = List.map (fun ty -> ty_of_dty (dty denv ty)) tyl 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 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 clause (id, f) =
let loc = f.pp_loc in let loc = f.pp_loc in
let f' = fmla th' f in let f' = fmla th' f in
check_clausal_form loc ps f'; 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 in
let cl = List.map clause cl 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 find_in_loadpath env f =
let rec find c lp = match lp, c with let rec find c lp = match lp, c with
......
...@@ -156,19 +156,23 @@ let print_logic_decl fmt = function ...@@ -156,19 +156,23 @@ let print_logic_decl fmt = function
fprintf fmt "@[<hov 2>logic %a :@ %a@]" print_ident ps.ls_name fprintf fmt "@[<hov 2>logic %a :@ %a@]" print_ident ps.ls_name
print_fmla (ps_defn_axiom fd) 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 let print_decl fmt d = match d.d_node with
| Dtype tl -> | Dtype tl ->
fprintf fmt "@[<hov>%a@ (* *)@]" (print_list newline print_ty_decl) tl fprintf fmt "@[<hov>%a@ (* *)@]" (print_list newline print_ty_decl) tl
| Dlogic ldl -> | Dlogic ldl ->
fprintf fmt "@[<hov>%a@ (* *)@]" fprintf fmt "@[<hov>%a@ (* *)@]"
(print_list newline print_logic_decl) ldl (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" fprintf fmt "%s %a :@ %a@\n"