Commit 0dc78832 authored by Jean-Christophe Filliâtre's avatar Jean-Christophe Filliâtre
Browse files

no more prelude theory for programs

parent 2899d9b7
...@@ -51,7 +51,18 @@ and type_var = { ...@@ -51,7 +51,18 @@ and type_var = {
} }
let tyvar v = Tyvar v let tyvar v = Tyvar v
let tyapp (s, tyl) = Tyapp (s, tyl)
let rec type_inst s ty = match ty.ty_node with
| Ty.Tyvar n -> Mtv.find n s
| Ty.Tyapp (ts, tyl) -> Tyapp (ts, List.map (type_inst s) tyl)
let tyapp ts tyl = match ts.ts_def with
| None ->
Tyapp (ts, tyl)
| Some ty ->
let add m v t = Mtv.add v t m in
let s = List.fold_left2 add Mtv.empty ts.ts_args tyl in
type_inst s ty
type dty = dty_view type dty = dty_view
......
...@@ -32,7 +32,7 @@ val create_ty_decl_var : ?loc:Ptree.loc -> user:bool -> tvsymbol -> type_var ...@@ -32,7 +32,7 @@ val create_ty_decl_var : ?loc:Ptree.loc -> user:bool -> tvsymbol -> type_var
type dty type dty
val tyvar : type_var -> dty val tyvar : type_var -> dty
val tyapp : tysymbol * dty list -> dty val tyapp : tysymbol -> dty list -> dty
type dty_view = type dty_view =
| Tyvar of type_var | Tyvar of type_var
......
...@@ -198,10 +198,6 @@ let add_ind_decls = with_tuples ~reset:true add_ind_decl ...@@ -198,10 +198,6 @@ let add_ind_decls = with_tuples ~reset:true add_ind_decl
let add_prop_decl = with_tuples ~reset:true add_prop_decl let add_prop_decl = with_tuples ~reset:true add_prop_decl
let rec type_inst s ty = match ty.ty_node with
| Ty.Tyvar n -> Mtv.find n s
| Ty.Tyapp (ts, tyl) -> tyapp (ts, List.map (type_inst s) tyl)
let rec dty uc env = function let rec dty uc env = function
| PPTtyvar {id=x} -> | PPTtyvar {id=x} ->
tyvar (find_user_type_var x env) tyvar (find_user_type_var x env)
...@@ -211,17 +207,10 @@ let rec dty uc env = function ...@@ -211,17 +207,10 @@ let rec dty uc env = function
let np = List.length p in let np = List.length p in
if np <> a then error ~loc (TypeArity (x, a, np)); if np <> a then error ~loc (TypeArity (x, a, np));
let tyl = List.map (dty uc env) p in let tyl = List.map (dty uc env) p in
begin match ts.ts_def with tyapp ts tyl
| None ->
tyapp (ts, tyl)
| Some ty ->
let add m v t = Mtv.add v t m in
let s = List.fold_left2 add Mtv.empty ts.ts_args tyl in
type_inst s ty
end
| PPTtuple tyl -> | PPTtuple tyl ->
let ts = ts_tuple (List.length tyl) in let ts = ts_tuple (List.length tyl) in
tyapp (ts, List.map (dty uc env) tyl) tyapp ts (List.map (dty uc env) tyl)
let find_ns find p ns = let find_ns find p ns =
let loc = qloc p in let loc = qloc p in
...@@ -407,7 +396,7 @@ and dpat_node loc uc env = function ...@@ -407,7 +396,7 @@ and dpat_node loc uc env = function
let s = fs_tuple n in let s = fs_tuple n in
let tyl = List.map (fun _ -> fresh_type_var loc) pl in let tyl = List.map (fun _ -> fresh_type_var loc) pl in
let env, pl = dpat_args s.ls_name loc uc env tyl pl in let env, pl = dpat_args s.ls_name loc uc env tyl pl in
let ty = tyapp (ts_tuple n, tyl) in let ty = tyapp (ts_tuple n) tyl in
env, Papp (s, pl), ty env, Papp (s, pl), ty
| PPpas (p, x) -> | PPpas (p, x) ->
let env, p = dpat uc env p in let env, p = dpat uc env p in
...@@ -493,16 +482,16 @@ and dterm_node ~localize loc uc env = function ...@@ -493,16 +482,16 @@ and dterm_node ~localize loc uc env = function
let s = fs_tuple n in let s = fs_tuple n in
let tyl = List.map (fun _ -> fresh_type_var loc) tl in let tyl = List.map (fun _ -> fresh_type_var loc) tl in
let tl = dtype_args s.ls_name loc uc env tyl tl in let tl = dtype_args s.ls_name loc uc env tyl tl in
let ty = tyapp (ts_tuple n, tyl) in let ty = tyapp (ts_tuple n) tyl in
Tapp (s, tl), ty Tapp (s, tl), ty
| PPinfix (e1, x, e2) -> | PPinfix (e1, x, e2) ->
let s, tyl, ty = specialize_fsymbol (Qident x) uc in let s, tyl, ty = specialize_fsymbol (Qident x) uc in
let tl = dtype_args s.ls_name loc uc env tyl [e1; e2] in let tl = dtype_args s.ls_name loc uc env tyl [e1; e2] in
Tapp (s, tl), ty Tapp (s, tl), ty
| PPconst (ConstInt _ as c) -> | PPconst (ConstInt _ as c) ->
Tconst c, tyapp (Ty.ts_int, []) Tconst c, tyapp Ty.ts_int []
| PPconst (ConstReal _ as c) -> | PPconst (ConstReal _ as c) ->
Tconst c, tyapp (Ty.ts_real, []) Tconst c, tyapp Ty.ts_real []
| PPlet (x, e1, e2) -> | PPlet (x, e1, e2) ->
let e1 = dterm ~localize uc env e1 in let e1 = dterm ~localize uc env e1 in
let ty = e1.dt_ty in let ty = e1.dt_ty in
...@@ -574,7 +563,7 @@ and dterm_node ~localize loc uc env = function ...@@ -574,7 +563,7 @@ and dterm_node ~localize loc uc env = function
| TRterm t -> | TRterm t ->
let id = { id = "fc"; id_lab = []; id_loc = loc } in let id = { id = "fc"; id_lab = []; id_loc = loc } in
let tyl,ty = List.fold_right (fun (_,uty) (tyl,ty) -> let tyl,ty = List.fold_right (fun (_,uty) (tyl,ty) ->
let nty = tyapp (ts_func, [uty;ty]) in ty :: tyl, nty) let nty = tyapp ts_func [uty;ty] in ty :: tyl, nty)
uqu ([],t.dt_ty) uqu ([],t.dt_ty)
in in
let h = { dt_node = Tvar id.id ; dt_ty = ty } in let h = { dt_node = Tvar id.id ; dt_ty = ty } in
...@@ -591,8 +580,8 @@ and dterm_node ~localize loc uc env = function ...@@ -591,8 +580,8 @@ and dterm_node ~localize loc uc env = function
| [] -> assert false | [] -> assert false
in in
let tyl,ty = List.fold_right (fun (_,uty) (tyl,ty) -> let tyl,ty = List.fold_right (fun (_,uty) (tyl,ty) ->
let nty = tyapp (ts_func, [uty;ty]) in ty :: tyl, nty) let nty = tyapp ts_func [uty;ty] in ty :: tyl, nty)
uqu ([],tyapp (ts_pred, [uty])) uqu ([], tyapp ts_pred [uty])
in in
let h = { dt_node = Tvar id.id ; dt_ty = ty } in let h = { dt_node = Tvar id.id ; dt_ty = ty } in
let h = List.fold_left2 (fun h (uid,uty) ty -> let h = List.fold_left2 (fun h (uid,uty) ty ->
......
...@@ -59,8 +59,6 @@ val create_denv : unit -> denv ...@@ -59,8 +59,6 @@ val create_denv : unit -> denv
val create_user_type_var : string -> Denv.type_var val create_user_type_var : string -> Denv.type_var
val find_user_type_var : string -> denv -> Denv.type_var val find_user_type_var : string -> denv -> Denv.type_var
val type_inst : Denv.dty Ty.Mtv.t -> Ty.ty -> Denv.dty
val mem_var : string -> denv -> bool val mem_var : string -> denv -> bool
val find_var : string -> denv -> Denv.dty val find_var : string -> denv -> Denv.dty
val add_var : string -> Denv.dty -> denv -> denv val add_var : string -> Denv.dty -> denv -> denv
......
...@@ -39,7 +39,7 @@ let add_module ?(type_only=false) env penv (ltm, lmod) m = ...@@ -39,7 +39,7 @@ let add_module ?(type_only=false) env penv (ltm, lmod) m =
if Mnm.mem id.id lmod then raise (Loc.Located (loc, ClashModule id.id)); if Mnm.mem id.id lmod then raise (Loc.Located (loc, ClashModule id.id));
let wp = not type_only in let wp = not type_only in
let uc = create_module (Ident.id_user id.id loc) in let uc = create_module (Ident.id_user id.id loc) in
let prelude = Env.find_theory env ["programs"] "Prelude" in let prelude = Env.find_theory env ["bool"] "Bool" in
let uc = use_export_theory uc prelude in let uc = use_export_theory uc prelude in
let uc = let uc =
List.fold_left (Pgm_typing.decl ~wp env penv ltm lmod) uc m.mod_decl List.fold_left (Pgm_typing.decl ~wp env penv ltm lmod) uc m.mod_decl
......
...@@ -20,6 +20,8 @@ ...@@ -20,6 +20,8 @@
open Why open Why
open Util open Util
open Ident open Ident
open Ty
open Decl
open Theory open Theory
open Term open Term
...@@ -162,7 +164,33 @@ let add_psymbol ps uc = ...@@ -162,7 +164,33 @@ let add_psymbol ps uc =
let ls_Exit = create_lsymbol (id_fresh "%Exit") [] (Some ty_exn) let ls_Exit = create_lsymbol (id_fresh "%Exit") [] (Some ty_exn)
let create_module n = (* type unit = () *)
let ty_unit = ty_tuple []
let ts_unit = create_tysymbol (id_fresh "unit") [] (Some ty_unit)
(* logic ignore 'a : () *)
let ts_label = create_tysymbol (id_fresh "label") [] None
let ty_label = ty_app ts_label []
let fs_at =
let ty = ty_var (create_tvsymbol (id_fresh "a")) in
create_lsymbol (id_fresh "at") [ty; ty_label] (Some ty)
let fs_old =
let ty = ty_var (create_tvsymbol (id_fresh "a")) in
create_lsymbol (id_fresh "old") [ty] (Some ty)
let th_prelude =
let uc = create_theory (id_fresh "Prelude") in
let uc = use_export uc (tuple_theory 0) in
let uc = add_ty_decl uc [ts_unit, Tabstract] in
let uc = add_ty_decl uc [ts_label, Tabstract] in
let uc = add_logic_decl uc [fs_at, None] in
let uc = add_logic_decl uc [fs_old, None] in
close_theory uc
let empty_module n =
let m = { let m = {
uc_name = id_register n; uc_name = id_register n;
uc_impure = Theory.create_theory n; uc_impure = Theory.create_theory n;
...@@ -236,6 +264,10 @@ let use_export_theory uc th = ...@@ -236,6 +264,10 @@ let use_export_theory uc th =
in in
add_ns th.th_export uc add_ns th.th_export uc
let create_module id =
let uc = empty_module id in
use_export_theory uc th_prelude
let add_impure_pdecl env ltm d uc = let add_impure_pdecl env ltm d uc =
{ uc with uc_impure = Typing.add_decl env ltm uc.uc_impure d } { uc with uc_impure = Typing.add_decl env ltm uc.uc_impure d }
......
...@@ -19,6 +19,7 @@ ...@@ -19,6 +19,7 @@
open Why open Why
open Ident open Ident
open Ty
open Term open Term
open Theory open Theory
open Pgm_types open Pgm_types
...@@ -83,6 +84,19 @@ val add_pdecl : ...@@ -83,6 +84,19 @@ val add_pdecl :
Env.env -> Theory.theory Theory.Mnm.t -> Ptree.decl -> uc -> uc Env.env -> Theory.theory Theory.Mnm.t -> Ptree.decl -> uc -> uc
(** add in impure, effect and pure *) (** add in impure, effect and pure *)
(** builtins *)
val ts_label : tysymbol
val ty_label : ty
val ts_unit : tysymbol
val ty_unit : ty
val fs_old : lsymbol
val fs_at : lsymbol
val th_prelude : theory
(** exceptions *) (** exceptions *)
exception CloseModule exception CloseModule
...@@ -80,18 +80,16 @@ let is_mutable_field ts i = ...@@ -80,18 +80,16 @@ let is_mutable_field ts i =
(* phase 1: typing programs (using destructive type inference) **************) (* phase 1: typing programs (using destructive type inference) **************)
let dty_app (ts, tyl) = assert (ts.ts_def = None); tyapp (ts, tyl)
let find_ts ~pure uc s = let find_ts ~pure uc s =
ns_find_ts (get_namespace (if pure then pure_uc uc else impure_uc uc)) [s] ns_find_ts (get_namespace (if pure then pure_uc uc else impure_uc uc)) [s]
let find_ls ~pure uc s = let find_ls ~pure uc s =
ns_find_ls (get_namespace (if pure then pure_uc uc else impure_uc uc)) [s] ns_find_ls (get_namespace (if pure then pure_uc uc else impure_uc uc)) [s]
(* TODO: improve efficiency *) (* TODO: improve efficiency *)
let dty_bool uc = dty_app (find_ts ~pure:true uc "bool", []) let dty_bool uc = tyapp (find_ts ~pure:true uc "bool") []
let dty_int _uc = dty_app (Ty.ts_int, []) let dty_int _uc = tyapp Ty.ts_int []
let dty_unit _uc = dty_app (ts_tuple 0, []) let dty_unit _uc = tyapp (ts_tuple 0) []
let dty_label uc = dty_app (find_ts ~pure:true uc "label_", []) let dty_label _uc = tyapp ts_label []
(* note: local variables are simultaneously in locals (to type programs) (* note: local variables are simultaneously in locals (to type programs)
and in denv (to type logic elements) *) and in denv (to type logic elements) *)
...@@ -111,7 +109,7 @@ let loc_of_id id = Util.of_option id.Ident.id_loc ...@@ -111,7 +109,7 @@ let loc_of_id id = Util.of_option id.Ident.id_loc
let loc_of_ls ls = ls.ls_name.Ident.id_loc let loc_of_ls ls = ls.ls_name.Ident.id_loc
let dcurrying tyl ty = let dcurrying tyl ty =
let make_arrow_type ty1 ty2 = dty_app (ts_arrow, [ty1; ty2]) in let make_arrow_type ty1 ty2 = tyapp ts_arrow [ty1; ty2] in
List.fold_right make_arrow_type tyl ty List.fold_right make_arrow_type tyl ty
type region_policy = Region_var | Region_ret | Region_glob type region_policy = Region_var | Region_ret | Region_glob
...@@ -176,7 +174,7 @@ let rec specialize_ty ?(policy=Region_var) ~loc htv ty = match ty.ty_node with ...@@ -176,7 +174,7 @@ let rec specialize_ty ?(policy=Region_var) ~loc htv ty = match ty.ty_node with
in in
let regions = List.map mk_region (Util.prefix n tl) in let regions = List.map mk_region (Util.prefix n tl) in
let tl = List.map (specialize_ty ~policy ~loc htv) (Util.chop n tl) in let tl = List.map (specialize_ty ~policy ~loc htv) (Util.chop n tl) in
tyapp (ts, regions @ tl) tyapp ts (regions @ tl)
let rec specialize_type_v ?(policy=Region_var) ~loc htv = function let rec specialize_type_v ?(policy=Region_var) ~loc htv = function
| Tpure ty -> | Tpure ty ->
...@@ -245,7 +243,7 @@ let dexception uc qid = ...@@ -245,7 +243,7 @@ let dexception uc qid =
let sl = Typing.string_list_of_qualid [] qid in let sl = Typing.string_list_of_qualid [] qid in
let loc = Typing.qloc qid in let loc = Typing.qloc qid in
let _, _, ty as r = specialize_exception loc sl uc in let _, _, ty as r = specialize_exception loc sl uc in
let ty_exn = dty_app (ts_exn, []) in let ty_exn = tyapp ts_exn [] in
if not (Denv.unify ty ty_exn) then if not (Denv.unify ty ty_exn) then
errorm ~loc errorm ~loc
"@[this expression has type %a,@ but is expected to be an exception@]" "@[this expression has type %a,@ but is expected to be an exception@]"
...@@ -291,17 +289,10 @@ let rec dtype ~user env = function ...@@ -291,17 +289,10 @@ let rec dtype ~user env = function
print_qualid x (a - mt.mt_regions) np; print_qualid x (a - mt.mt_regions) np;
let tyl = List.map (dtype ~user env) p in let tyl = List.map (dtype ~user env) p in
let tyl = create_regions ~user mt.mt_regions @ tyl in let tyl = create_regions ~user mt.mt_regions @ tyl in
begin match ts.ts_def with tyapp ts tyl
| None ->
tyapp (ts, tyl)
| Some ty ->
let add m v t = Mtv.add v t m in
let s = List.fold_left2 add Mtv.empty ts.ts_args tyl in
Typing.type_inst s ty
end
| PPTtuple tyl -> | PPTtuple tyl ->
let ts = ts_tuple (List.length tyl) in let ts = ts_tuple (List.length tyl) in
tyapp (ts, List.map (dtype ~user env) tyl) tyapp ts (List.map (dtype ~user env) tyl)
let rec dutype_v env = function let rec dutype_v env = function
| Ptree.Tpure pt -> | Ptree.Tpure pt ->
...@@ -389,9 +380,9 @@ let rec dexpr ~ghost env e = ...@@ -389,9 +380,9 @@ let rec dexpr ~ghost env e =
and dexpr_desc ~ghost env loc = function and dexpr_desc ~ghost env loc = function
| Ptree.Econstant (ConstInt _ as c) -> | Ptree.Econstant (ConstInt _ as c) ->
DEconstant c, dty_app (Ty.ts_int, []) DEconstant c, tyapp Ty.ts_int []
| Ptree.Econstant (ConstReal _ as c) -> | Ptree.Econstant (ConstReal _ as c) ->
DEconstant c, dty_app (Ty.ts_real, []) DEconstant c, tyapp Ty.ts_real []
| Ptree.Eident (Qident {id=x}) when Mstr.mem x env.locals -> | Ptree.Eident (Qident {id=x}) when Mstr.mem x env.locals ->
(* local variable *) (* local variable *)
let tyv = Mstr.find x env.locals in let tyv = Mstr.find x env.locals in
...@@ -437,7 +428,7 @@ and dexpr_desc ~ghost env loc = function ...@@ -437,7 +428,7 @@ and dexpr_desc ~ghost env loc = function
let ghost = ghost (* || is_ps_ghost e1 *) in let ghost = ghost (* || is_ps_ghost e1 *) in
let e2 = dexpr ~ghost env e2 in let e2 = dexpr ~ghost env e2 in
let ty2 = create_type_var loc and ty = create_type_var loc in let ty2 = create_type_var loc and ty = create_type_var loc in
if not (Denv.unify e1.dexpr_type (dty_app (ts_arrow, [ty2; ty]))) then if not (Denv.unify e1.dexpr_type (tyapp ts_arrow [ty2; ty])) then
errorm ~loc:e1.dexpr_loc "this expression is not a function"; errorm ~loc:e1.dexpr_loc "this expression is not a function";
expected_type e2 ty2; expected_type e2 ty2;
DEapply (e1, e2), ty DEapply (e1, e2), ty
...@@ -461,13 +452,13 @@ and dexpr_desc ~ghost env loc = function ...@@ -461,13 +452,13 @@ and dexpr_desc ~ghost env loc = function
let n = List.length el in let n = List.length el in
let s = Typing.fs_tuple n in let s = Typing.fs_tuple n in
let tyl = List.map (fun _ -> create_type_var loc) el in let tyl = List.map (fun _ -> create_type_var loc) el in
let ty = dty_app (Typing.ts_tuple n, tyl) in let ty = tyapp (Typing.ts_tuple n) tyl in
let create d ty = { dexpr_desc = d; dexpr_type = ty; dexpr_loc = loc } in let create d ty = { dexpr_desc = d; dexpr_type = ty; dexpr_loc = loc } in
let apply e1 e2 ty2 = let apply e1 e2 ty2 =
let e2 = dexpr ~ghost env e2 in let e2 = dexpr ~ghost env e2 in
assert (Denv.unify e2.dexpr_type ty2); assert (Denv.unify e2.dexpr_type ty2);
let ty = create_type_var loc in let ty = create_type_var loc in
assert (Denv.unify e1.dexpr_type (dty_app (ts_arrow, [ty2; ty]))); assert (Denv.unify e1.dexpr_type (tyapp ts_arrow [ty2; ty]));
create (DEapply (e1, e2)) ty create (DEapply (e1, e2)) ty
in in
let e = create (DElogic s) (dcurrying tyl ty) in let e = create (DElogic s) (dcurrying tyl ty) in
...@@ -484,7 +475,7 @@ and dexpr_desc ~ghost env loc = function ...@@ -484,7 +475,7 @@ and dexpr_desc ~ghost env loc = function
let f = dexpr ~ghost env f in let f = dexpr ~ghost env f in
assert (Denv.unify f.dexpr_type tyf); assert (Denv.unify f.dexpr_type tyf);
let ty = create_type_var loc in let ty = create_type_var loc in
assert (Denv.unify d.dexpr_type (dty_app (ts_arrow, [tyf; ty]))); assert (Denv.unify d.dexpr_type (tyapp ts_arrow [tyf; ty]));
create (DEapply (d, f)) ty create (DEapply (d, f)) ty
| None -> | None ->
errorm ~loc "some record fields are missing" errorm ~loc "some record fields are missing"
...@@ -704,7 +695,7 @@ let rec dty_of_ty denv ty = match ty.ty_node with ...@@ -704,7 +695,7 @@ let rec dty_of_ty denv ty = match ty.ty_node with
| Ty.Tyvar v -> | Ty.Tyvar v ->
Denv.tyvar (Typing.find_user_type_var v.tv_name.id_string denv) Denv.tyvar (Typing.find_user_type_var v.tv_name.id_string denv)
| Ty.Tyapp (ts, tyl) -> | Ty.Tyapp (ts, tyl) ->
Denv.tyapp (ts, List.map (dty_of_ty denv) tyl) Denv.tyapp ts (List.map (dty_of_ty denv) tyl)
let iadd_local env x ty = let iadd_local env x ty =
let v = create_ivsymbol x ty in let v = create_ivsymbol x ty in
...@@ -1165,8 +1156,7 @@ and iexpr_desc gl env loc ty = function ...@@ -1165,8 +1156,7 @@ and iexpr_desc gl env loc ty = function
let f = ifmla env f in let f = ifmla env f in
IEassert (k, f) IEassert (k, f)
| DElabel (s, e1) -> | DElabel (s, e1) ->
let ty = Ty.ty_app (find_ts ~pure:true gl "label_") [] in let env, v = iadd_local env (id_fresh s) ty_label in
let env, v = iadd_local env (id_fresh s) ty in
IElabel (v.i_impure, iexpr gl env e1) IElabel (v.i_impure, iexpr gl env e1)
| DEany c -> | DEany c ->
let c = iutype_c gl env c in let c = iutype_c gl env c in
...@@ -1408,7 +1398,7 @@ let mk_false loc gl = mk_bool_constant loc gl (find_ls ~pure:true gl "False") ...@@ -1408,7 +1398,7 @@ let mk_false loc gl = mk_bool_constant loc gl (find_ls ~pure:true gl "False")
let mk_true loc gl = mk_bool_constant loc gl (find_ls ~pure:true gl "True") let mk_true loc gl = mk_bool_constant loc gl (find_ls ~pure:true gl "True")
(* check that variables occurring in 'old' and 'at' are not local variables *) (* check that variables occurring in 'old' and 'at' are not local variables *)
let check_at_fmla f = let check_at_fmla _f =
assert false (*TODO*) assert false (*TODO*)
(* Saturation of postconditions: a postcondition must be set for (* Saturation of postconditions: a postcondition must be set for
......
...@@ -99,9 +99,8 @@ let wp_forall v f = ...@@ -99,9 +99,8 @@ let wp_forall v f =
(* utility functions for building WPs *) (* utility functions for building WPs *)
let fresh_label env = let fresh_label () =
let ty = ty_app (find_ts ~pure:true env "label_") [] in create_vsymbol (id_fresh "label") ty_label
create_vsymbol (id_fresh "label") ty
let wp_binder x f = match x.pv_tv with let wp_binder x f = match x.pv_tv with
| Tpure _ -> wp_forall x.pv_pure f | Tpure _ -> wp_forall x.pv_pure f
...@@ -121,46 +120,31 @@ let add_binder x rm = ...@@ -121,46 +120,31 @@ let add_binder x rm =
let add_binders = List.fold_right add_binder let add_binders = List.fold_right add_binder
(* replace old(t) with at(t,lab) everywhere in formula f *) (* replace old(t) with at(t,lab) everywhere in formula f *)
let rec old_label env lab f = let rec old_label lab t = match t.t_node with
TermTF.t_map (old_label_term env lab) (old_label env lab) f | Tapp (ls, [t]) when ls_equal ls fs_old ->
let t = old_label lab t in (* NECESSARY? *)
and old_label_term env lab t = match t.t_node with t_app fs_at [t; t_var lab] t.t_ty
| Tapp (ls, [t]) when ls_equal ls (find_ls ~pure:true env "old") ->
let t = old_label_term env lab t in (* NECESSARY? *)
t_app (find_ls ~pure:true env "at") [t; t_var lab] t.t_ty
| _ -> | _ ->
TermTF.t_map (old_label_term env lab) (old_label env lab) t t_map (old_label lab) t
(* replace at(t,lab) with t everywhere in formula f *) (* replace at(t,lab) with t everywhere in formula f *)
let rec erase_label env lab f = let rec erase_label lab t = match t.t_node with
TermTF.t_map (erase_label_term env lab) (erase_label env lab) f
and erase_label_term env lab t = match t.t_node with
| Tapp (ls, [t; {t_node = Tvar l}]) | Tapp (ls, [t; {t_node = Tvar l}])
when ls_equal ls (find_ls ~pure:true env "at") && vs_equal l lab -> when ls_equal ls fs_at && vs_equal l lab ->
erase_label_term env lab t erase_label lab t
| _ -> | _ ->
TermTF.t_map (erase_label_term env lab) (erase_label env lab) t t_map (erase_label lab) t
let rec unref env s f = let rec unref s t = match t.t_node with
TermTF.t_map (unref_term env s) (unref env s) f
and unref_term env s t = match t.t_node with
(***
| R.Rglobal {p_ls=ls1}, Tapp (ls2, _) when ls_equal ls1 ls2 ->
t_var v
| R.Rlocal {pv_vs=vs1}, Tvar vs2 when vs_equal vs1 vs2 ->
t_var v
***)
| Tvar vs -> | Tvar vs ->
begin try t_var (Mvs.find vs s) with Not_found -> t end begin try t_var (Mvs.find vs s) with Not_found -> t end
| Tapp (ls, _) when ls_equal ls (find_ls ~pure:true env "old") -> | Tapp (ls, _) when ls_equal ls fs_old ->
assert false assert false
| Tapp (ls, _) when ls_equal ls (find_ls ~pure:true env "at") -> | Tapp (ls, _) when ls_equal ls fs_at ->
(* do not recurse in at(...) *) (* do not recurse in at(...) *)
t t
| _ -> | _ ->
TermTF.t_map (unref_term env s) (unref env s) t t_map (unref s) t
let find_constructor env ts = let find_constructor env ts =
let km = get_known (pure_uc env) in let km = get_known (pure_uc env) in
...@@ -268,7 +252,7 @@ let quantify env rm sreg f = ...@@ -268,7 +252,7 @@ let quantify env rm sreg f =
in in