Commit 8874bce9 authored by Andrei Paskevich's avatar Andrei Paskevich

- make the interface to ls_defn more straightforward

- assure generation of new variables on create_ls_defn
parent 38810ff7
......@@ -278,7 +278,7 @@ 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_ls_defn fmt ld =
let _,vl,e = open_ls_defn ld in
let vl,e = open_ls_defn ld in
fprintf fmt " =@ %a" print_expr e;
List.iter forget_var vl
......
......@@ -43,24 +43,6 @@ type logic_decl = lsymbol * ls_defn option
exception UnboundVars of Svs.t
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, 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, Fmla f, check_fvs pd
let make_ls_defn ls vl =
e_apply (make_fs_defn ls vl) (make_ps_defn ls vl)
let extract_ls_defn f =
let vl, ef = f_open_forall f in
match ef.f_node with
......@@ -76,15 +58,28 @@ let extract_ls_defn f =
end
| _ -> assert false
let open_ls_defn (ls,vl,e,_) = (ls,vl,e)
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
extract_ls_defn 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
extract_ls_defn pd
let make_ls_defn ls vl = e_apply (make_fs_defn ls vl) (make_ps_defn ls vl)
let open_fs_defn = function (_,vl,Term t,_) -> (vl,t) | _ -> assert false
let open_fs_defn = function
| (fs,vl,Term t,_) -> (fs,vl,t)
| _ -> assert false
let open_ps_defn = function (_,vl,Fmla f,_) -> (vl,f) | _ -> assert false
let open_ps_defn = function
| (ps,vl,Fmla f,_) -> (ps,vl,f)
| _ -> assert false
let open_ls_defn (_,vl,e,_) = (vl,e)
let ls_defn_axiom (_,_,_,f) = f
......
......@@ -35,17 +35,17 @@ type ty_decl = tysymbol * ty_def
type ls_defn
val make_ls_defn : lsymbol -> vsymbol list -> expr -> ls_defn
val make_fs_defn : lsymbol -> vsymbol list -> term -> ls_defn
val make_ps_defn : lsymbol -> vsymbol list -> fmla -> ls_defn
type logic_decl = lsymbol * ls_defn option
val open_ls_defn : ls_defn -> lsymbol * vsymbol list * expr
val open_fs_defn : ls_defn -> lsymbol * vsymbol list * term
val open_ps_defn : ls_defn -> lsymbol * vsymbol list * fmla
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 ls_defn_axiom : ls_defn -> fmla
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
type logic_decl = lsymbol * ls_defn option
val ls_defn_axiom : ls_defn -> fmla
(* inductive predicate declaration *)
......
......@@ -160,7 +160,7 @@ let print_logic_decl drv ctxt fmt (ls,ld) =
(print_list comma (print_type drv)) ls.ls_args
(print_option_or_default "prop" (print_type drv)) ls.ls_value
| Some ld ->
let _,vl,e = open_ls_defn ld in
let vl,e = open_ls_defn ld in
begin match e with
| Term t ->
(* TODO AC? *)
......
......@@ -292,7 +292,7 @@ let print_type_decl drv fmt d =
| _ -> print_type_decl drv fmt d; forget_tvs ()
let print_ls_defn drv fmt ld =
let _,vl,e = open_ls_defn ld in
let vl,e = open_ls_defn ld in
fprintf fmt " =@ %a" (print_expr drv) e;
List.iter forget_var vl
......
......@@ -870,8 +870,8 @@ let add_logics dl th =
match d.ld_type with
| None -> (* predicate *)
let ps = Hashtbl.find psymbols id in
let defn = match d.ld_def with
| None -> None
begin match d.ld_def with
| None -> ps,None
| Some f ->
let f = dfmla denv f in
let vl = match ps.ls_value with
......@@ -879,13 +879,12 @@ let add_logics dl th =
| _ -> assert false
in
let env = env_of_vsymbol_list vl in
Some (make_ps_defn ps vl (fmla env f))
in
ps, defn
make_ps_defn ps vl (fmla env f)
end
| Some ty -> (* function *)
let fs = Hashtbl.find fsymbols id in
let defn = match d.ld_def with
| None -> None
begin match d.ld_def with
| None -> fs,None
| Some t ->
let loc = t.pp_loc in
let t = dterm denv t in
......@@ -894,15 +893,13 @@ let add_logics dl th =
| _ -> assert false
in
let env = env_of_vsymbol_list vl in
try Some (make_fs_defn fs vl (term env t))
try make_fs_defn fs vl (term env t)
with _ -> term_expected_type ~loc t.dt_ty (dty denv ty)
in
fs, defn
end
in
let dl = List.map type_decl dl in
List.fold_left add_decl th (create_logic_decls dl)
let term env t =
let denv = create_denv env in
let t = dterm denv t in
......
......@@ -75,19 +75,19 @@ let fold isnotinlinedt isnotinlinedf ctxt0 (env, ctxt) =
match ld with
| None -> env,add_decl ctxt d
| Some ld ->
let _,vs,e = open_ls_defn ld in
let vs,e = open_ls_defn ld in
match e with
| Term t ->
let t = replacet env t in
if t_s_any ffalse ((==) ls) t || isnotinlinedt t
then env, add_decl ctxt
(create_logic_decl [(ls, Some (make_fs_defn ls vs t))])
(create_logic_decl [make_fs_defn ls vs t])
else {env with fs = Mls.add ls (vs,t) env.fs},ctxt
| Fmla f ->
let f = replacep env f in
if f_s_any ffalse ((==) ls) f || isnotinlinedf f
then env, add_decl ctxt
(create_logic_decl [(ls,Some (make_ps_defn ls vs f))])
(create_logic_decl [make_ps_defn ls vs f])
else {env with ps = Mls.add ls (vs,f) env.ps},ctxt
end
| Dind dl ->
......@@ -97,10 +97,12 @@ let fold isnotinlinedt isnotinlinedf ctxt0 (env, ctxt) =
| Dlogic dl ->
env,
add_decl ctxt (create_logic_decl
(List.map (fun (ls,ld) -> ls, Util.option_map (fun ld ->
let _,vs,e = open_ls_defn ld in
let e = e_map (replacet env) (replacep env) e in
make_ls_defn ls vs e) ld) dl))
(List.map (fun (ls,ld) -> match ld with
| None -> ls, None
| Some ld ->
let vs,e = open_ls_defn ld in
let e = e_map (replacet env) (replacep env) e in
make_ls_defn ls vs e) dl))
| Dtype dl -> env,add_decl ctxt d
| Dprop (k,pr,f) ->
env,add_decl ctxt (create_prop_decl k pr (replacep env f))
......
......@@ -241,9 +241,9 @@ let rewrite_elt rt rf d =
| Dlogic l -> [create_logic_decl (List.map
(function
| (ls,Some def) ->
let (ls,vsl,expr) = open_ls_defn def in
let vsl,expr = open_ls_defn def in
let expr = e_map rt rf expr in
(ls,Some (make_ls_defn ls vsl expr))
make_ls_defn ls vsl expr
| l -> l) l)]
| Dind indl -> [create_ind_decl
(List.map (fun (ls,pl) -> ls,
......
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