Commit c0696892 authored by Andrei Paskevich's avatar Andrei Paskevich

whyml: back to the KISS principle

Merge specifications into program types, as JCF intended.
parent 14c2c552
......@@ -178,7 +178,7 @@ let letvar_news = function
| LetA ps -> check_vars ps.ps_vars; Sid.singleton ps.ps_name
let create_let_decl ld =
let news = letvar_news ld.let_var in
let news = letvar_news ld.let_sym in
(*
let syms = syms_varmap Sid.empty ld.let_expr.e_vars in
let syms = syms_effect syms ld.let_expr.e_effect in
......@@ -207,7 +207,7 @@ let create_rec_decl rdl =
mk_decl (PDrec rdl) (*syms*) news
let create_val_decl vd =
let news = letvar_news vd.val_name in
let news = letvar_news vd.val_sym in
(*
let syms = syms_type_v Sid.empty vd.val_spec in
let syms = syms_varmap syms vd.val_vars in
......
......@@ -202,8 +202,9 @@ let unify d1 d2 = unify ~weak:false d1 d2
type dvty = dity list * dity (* A -> B -> C == ([A;B],C) *)
let vty_of_dvty (argl,res) =
let add a v = VTarrow (vty_arrow (vty_value (ity_of_dity a)) v) in
List.fold_right add argl (VTvalue (vty_value (ity_of_dity res)))
let vtv = VTvalue (vty_value (ity_of_dity res)) in
let conv a = create_pvsymbol (id_fresh "x") (vty_value (ity_of_dity a)) in
if argl = [] then vtv else VTarrow (vty_arrow (List.map conv argl) vtv)
type tvars = dity list
......@@ -284,14 +285,14 @@ let specialize_xsymbol xs =
let specialize_vtarrow vars vta =
let htv = Htv.create 3 and hreg = Hreg.create 3 in
let conv vtv = dity_of_vtv htv hreg vars vtv in
let conv pv = dity_of_vtv htv hreg vars pv.pv_vtv in
let rec specialize a =
let arg = conv a.vta_arg in
let argl,res = match a.vta_result with
| VTvalue v -> [], conv v
let argl = List.map conv a.vta_args in
let narg,res = match a.vta_result with
| VTvalue v -> [], dity_of_vtv htv hreg vars v
| VTarrow a -> specialize a
in
arg::argl, res
argl @ narg, res
in
specialize vta
......
This diff is collapsed.
......@@ -27,26 +27,6 @@ open Term
open Mlw_ty
open Mlw_ty.T
(** program variables *)
(* pvsymbols represent function arguments and pattern variables *)
type pvsymbol = private {
pv_vs : vsymbol;
pv_vtv : vty_value;
}
module Mpv : Map.S with type key = pvsymbol
module Spv : Mpv.Set
module Hpv : Hashtbl.S with type key = pvsymbol
module Wpv : Hashweak.S with type key = pvsymbol
val pv_equal : pvsymbol -> pvsymbol -> bool
val create_pvsymbol : preid -> vty_value -> pvsymbol
val restore_pv : vsymbol -> pvsymbol
(** program symbols *)
(* psymbols represent lambda-abstractions. They are polymorphic and
......@@ -59,17 +39,12 @@ type psymbol = private {
ps_vars : varset;
(* this varset covers the type variables and regions of the defining
lambda that cannot be instantiated. Every other type variable
and region in ps_vty is generalized and can be instantiated. *)
and region in ps_vta is generalized and can be instantiated. *)
ps_subst : ity_subst;
(* this substitution instantiates every type variable and region
in ps_vars to itself *)
}
module Mps : Map.S with type key = psymbol
module Sps : Mps.Set
module Hps : Hashtbl.S with type key = psymbol
module Wps : Hashweak.S with type key = psymbol
val ps_equal : psymbol -> psymbol -> bool
val create_psymbol : preid -> vty_arrow -> psymbol
......@@ -102,39 +77,17 @@ exception HiddenPLS of lsymbol
(** specification *)
type pre = term (* precondition: pre_fmla *)
type post = term (* postcondition: eps result . post_fmla *)
type xpost = post Mexn.t (* exceptional postconditions *)
val create_post : vsymbol -> term -> post
val open_post : post -> vsymbol * term
type type_c = {
c_pre : pre;
c_effect : effect;
c_result : type_v;
c_post : post;
c_xpost : xpost;
}
and type_v =
| SpecV of vty_value
| SpecA of pvsymbol list * type_c
type let_var =
type let_sym =
| LetV of pvsymbol
| LetA of psymbol
type val_decl = private {
val_name : let_var;
val_spec : type_v;
val_vars : varset Mid.t;
val_sym : let_sym;
val_vty : vty;
val_vars : varmap;
}
val create_val : Ident.preid -> type_v -> val_decl
exception DuplicateArg of pvsymbol
exception UnboundException of xsymbol
val create_val : Ident.preid -> vty -> val_decl
(** patterns *)
......@@ -175,24 +128,23 @@ type expr = private {
e_node : expr_node;
e_vty : vty;
e_effect : effect;
e_vars : varset Mid.t;
e_vars : varmap;
e_label : Slab.t;
e_loc : Loc.position option;
e_tag : Hashweak.tag;
}
and expr_node = private
| Elogic of term
| Evalue of pvsymbol
| Earrow of psymbol
| Eapp of expr * pvsymbol
| Eapp of expr * pvsymbol * spec
| Elet of let_defn * expr
| Erec of rec_defn list * expr
| Eif of expr * expr * expr
| Ecase of expr * (ppattern * expr) list
| Eassign of expr * region * pvsymbol
| Eghost of expr
| Eany of type_c
| Eany of spec
| Eloop of invariant * variant list * expr
| Efor of pvsymbol * for_bounds * invariant * expr
| Eraise of xsymbol * expr
......@@ -202,14 +154,14 @@ and expr_node = private
| Eabsurd
and let_defn = private {
let_var : let_var;
let_sym : let_sym;
let_expr : expr;
}
and rec_defn = private {
rec_ps : psymbol;
rec_lambda : lambda;
rec_vars : varset Mid.t;
rec_vars : varmap;
}
and lambda = {
......@@ -226,11 +178,6 @@ and variant = {
v_rel : lsymbol option; (* tau tau : prop *)
}
module Mexpr : Map.S with type key = expr
module Sexpr : Mexpr.Set
module Hexpr : Hashtbl.S with type key = expr
module Wexpr : Hashweak.S with type key = expr
val e_label : ?loc:Loc.position -> Slab.t -> expr -> expr
val e_label_add : label -> expr -> expr
val e_label_copy : expr -> expr -> expr
......@@ -269,7 +216,7 @@ exception Immutable of expr
val e_assign : expr -> expr -> expr
val e_ghost : expr -> expr
val e_any : type_c -> expr
val e_any : spec -> vty -> expr
val e_void : expr
......
......@@ -311,7 +311,7 @@ let add_pdecl uc d =
let defn cl = List.map constructor cl in
let dl = List.map (fun (its,cl) -> its.its_pure, defn cl) dl in
add_to_theory Theory.add_data_decl uc dl
| PDval { val_name = lv } | PDlet { let_var = lv } ->
| PDval { val_sym = lv } | PDlet { let_sym = lv } ->
add_let uc lv
| PDrec rdl ->
List.fold_left add_rec uc rdl
......
......@@ -130,8 +130,9 @@ let print_vtv fmt vtv =
fprintf fmt "%s%a" (if vtv.vtv_ghost then "?" else "") print_ity vtv.vtv_ity
let rec print_vta fmt vta =
fprintf fmt "%a ->@ %a%a" print_vtv vta.vta_arg
print_effect vta.vta_effect print_vty vta.vta_result
let print_arg fmt pv = fprintf fmt "%a ->@ " print_vtv pv.pv_vtv in
fprintf fmt "%a%a%a" (print_list nothing print_arg) vta.vta_args
print_effect vta.vta_spec.c_effect print_vty vta.vta_result
and print_vty fmt = function
| VTarrow vta -> print_vta fmt vta
......@@ -168,18 +169,20 @@ let forget_lv = function
| LetA ps -> forget_ps ps
let rec print_type_v fmt = function
| SpecV vtv -> print_vtv fmt vtv
| SpecA (pvl,tyc) ->
| VTvalue vtv -> print_vtv fmt vtv
| VTarrow vta ->
let print_arg fmt pv = fprintf fmt "@[(%a)@] ->@ " print_pvty pv in
fprintf fmt "%a%a" (print_list nothing print_arg) pvl print_type_c tyc;
List.iter forget_pv pvl
fprintf fmt "%a%a"
(print_list nothing print_arg) vta.vta_args
(print_type_c vta.vta_spec) vta.vta_result;
List.iter forget_pv vta.vta_args
and print_type_c fmt tyc =
and print_type_c spec fmt vty =
fprintf fmt "{ %a }@ %a%a@ { %a }"
print_term tyc.c_pre
print_effect tyc.c_effect
print_type_v tyc.c_result
print_post tyc.c_post
print_term spec.c_pre
print_effect spec.c_effect
print_type_v vty
print_post spec.c_post
(* TODO: print_xpost *)
let print_invariant fmt f =
......@@ -262,14 +265,14 @@ and print_enode pri fmt e = match e.e_node with
print_pv fmt v
| Earrow a ->
print_ps fmt a
| Eapp (e,v) ->
| Eapp (e,v,_) ->
fprintf fmt "(%a@ %a)" (print_lexpr pri) e print_pv v
| Elet ({ let_var = LetV pv ; let_expr = e1 }, e2)
| Elet ({ let_sym = LetV pv ; let_expr = e1 }, e2)
when pv.pv_vs.vs_name.id_string = "_" &&
ity_equal pv.pv_vtv.vtv_ity ity_unit ->
fprintf fmt (protect_on (pri > 0) "%a;@\n%a")
print_expr e1 print_expr e2;
| Elet ({ let_var = lv ; let_expr = e1 }, e2) ->
| Elet ({ let_sym = lv ; let_expr = e1 }, e2) ->
fprintf fmt (protect_on (pri > 0) "@[<hov 2>let %a =@ %a@ in@]@\n%a")
print_lv lv (print_lexpr 4) e1 print_expr e2;
forget_lv lv
......@@ -309,8 +312,8 @@ and print_enode pri fmt e = match e.e_node with
fprintf fmt "abstract %a@ { %a }" print_expr e print_post q
| Eghost e ->
fprintf fmt "ghost@ %a" print_expr e
| Eany tyc ->
fprintf fmt "any@ %a" print_type_c tyc
| Eany spec ->
fprintf fmt "any@ %a" (print_type_c spec) e.e_vty
and print_branch fmt ({ ppat_pattern = p }, e) =
fprintf fmt "@[<hov 4>| %a ->@ %a@]" print_pat p print_expr e;
......@@ -388,12 +391,12 @@ let print_data_decl fst fmt (ts,csl) =
(print_head fst) ts (print_list newline print_constr) csl;
forget_tvs_regs ()
let print_val_decl fmt { val_name = lv ; val_spec = tyv } =
fprintf fmt "@[<hov 2>val (%a) :@ %a@]" print_lv lv print_type_v tyv;
let print_val_decl fmt { val_sym = lv ; val_vty = vty } =
fprintf fmt "@[<hov 2>val (%a) :@ %a@]" print_lv lv print_type_v vty;
(* FIXME: don't forget global regions *)
forget_tvs_regs ()
let print_let_decl fmt { let_var = lv ; let_expr = e } =
let print_let_decl fmt { let_sym = lv ; let_expr = e } =
fprintf fmt "@[<hov 2>let %a =@ %a@]" print_lv lv print_expr e;
(* FIXME: don't forget global regions *)
forget_tvs_regs ()
......@@ -438,6 +441,9 @@ let () = Exn_printer.register
fprintf fmt "Region %a is used twice" print_reg r
| Mlw_ty.UnboundRegion r ->
fprintf fmt "Unbound region %a" print_reg r
| Mlw_ty.UnboundException xs ->
fprintf fmt "This function raises %a but does not \
specify a post-condition for it" print_xs xs
| Mlw_ty.RegionMismatch (r1,r2) ->
fprintf fmt "Region mismatch between %a and %a"
print_regty r1 print_regty r2
......@@ -467,10 +473,5 @@ let () = Exn_printer.register
fprintf fmt "This expression is not a function and cannot be applied"
| Mlw_expr.Immutable _e ->
fprintf fmt "Mutable expression expected"
| Mlw_expr.UnboundException xs ->
fprintf fmt "This function raises %a but does not \
specify a post-condition for it" print_xs xs
| Mlw_expr.DuplicateArg pv ->
fprintf fmt "Argument %a is used twice" print_pv pv
| _ -> raise exn
end
......@@ -53,9 +53,6 @@ val print_ppat : formatter -> ppattern -> unit (* program patterns *)
val print_expr : formatter -> expr -> unit (* expression *)
val print_type_c : formatter -> type_c -> unit
val print_type_v : formatter -> type_v -> unit
val print_ty_decl : formatter -> itysymbol -> unit
val print_data_decl : formatter -> data_decl -> unit
val print_next_data_decl : formatter -> data_decl -> unit
......
This diff is collapsed.
......@@ -33,6 +33,8 @@ module rec T : sig
vars_reg : Mreg.Set.t;
}
type varmap = varset Mid.t
type itysymbol = private {
its_pure : tysymbol;
its_args : tvsymbol list;
......@@ -171,6 +173,8 @@ val vars_empty : varset
val vars_union : varset -> varset -> varset
val vars_merge : varmap -> varset -> varset
val vars_freeze : varset -> ity_subst
val create_varset : Stv.t -> Sreg.t -> varset
......@@ -191,7 +195,8 @@ val create_xsymbol : preid -> ity -> xsymbol
module Mexn: Map.S with type key = xsymbol
module Sexn: Mexn.Set
(* effects *)
(** effects *)
type effect = private {
eff_reads : Sreg.t;
eff_writes : Sreg.t;
......@@ -224,9 +229,24 @@ val eff_filter : varset -> effect -> effect
val eff_is_empty : effect -> bool
(** program types *)
(** specification *)
type pre = term (* precondition: pre_fmla *)
type post = term (* postcondition: eps result . post_fmla *)
type xpost = post Mexn.t (* exceptional postconditions *)
val create_post : vsymbol -> term -> post
val open_post : post -> vsymbol * term
type spec = {
c_pre : pre;
c_post : post;
c_xpost : xpost;
c_effect : effect;
}
(** program variables *)
(* type of function arguments and values *)
type vty_value = private {
vtv_ity : ity;
vtv_ghost : bool;
......@@ -234,45 +254,74 @@ type vty_value = private {
vtv_vars : varset;
}
val vty_value : ?ghost:bool -> ?mut:region -> ity -> vty_value
val vtv_unmut : vty_value -> vty_value (* remove mutability *)
type pvsymbol = private {
pv_vs : vsymbol;
pv_vtv : vty_value;
}
module Mpv : Map.S with type key = pvsymbol
module Spv : Mpv.Set
module Hpv : Hashtbl.S with type key = pvsymbol
module Wpv : Hashweak.S with type key = pvsymbol
val pv_equal : pvsymbol -> pvsymbol -> bool
val create_pvsymbol : preid -> vty_value -> pvsymbol
val restore_pv : vsymbol -> pvsymbol
(* raises Decl.UnboundVar if the argument is not a pv_vs *)
(** program types *)
type vty =
| VTvalue of vty_value
| VTarrow of vty_arrow
and vty_arrow = private {
vta_arg : vty_value;
vta_args : pvsymbol list;
vta_result : vty;
vta_effect : effect;
vta_spec : spec;
vta_ghost : bool;
vta_vars : varset;
(* this varset covers every type variable and region in vta_arg
and vta_result, but not necessarily in vta_effect *)
and vta_result, but not necessarily in vta_spec *)
}
(* smart constructors *)
val vty_value : ?ghost:bool -> ?mut:region -> ity -> vty_value
val vty_arrow : vty_value -> ?effect:effect -> ?ghost:bool -> vty -> vty_arrow
exception UnboundException of xsymbol
val vty_app_arrow : vty_arrow -> vty_value -> effect * vty
val vty_vars : varset -> vty -> varset
val vty_ghost : vty -> bool
val vty_ghostify : vty -> vty
val vtv_unmut : vty_value -> vty_value
(* every raised exception must have a postcondition in spec.c_xpost *)
val vty_arrow : pvsymbol list -> ?spec:spec -> ?ghost:bool -> vty -> vty_arrow
(* this only compares the types of arguments and results, and ignores
the effects. In other words, only the type variables and regions
the spec. In other words, only the type variables and regions
in .vta_vars are matched. The caller should supply a "freezing"
substitution that covers all external type variables and regions. *)
val vta_vars_match : ity_subst -> vty_arrow -> vty_arrow -> ity_subst
(* the substitution must cover not only vta_vars but also every
type variable and every region in vta_effect *)
type variable and every region in vta_spec *)
val vta_full_inst : ity_subst -> vty_arrow -> vty_arrow
(* remove from the given arrow every effect that is covered
neither by the arrow's vta_vars nor by the given varset *)
val vta_filter : varset -> vty_arrow -> vty_arrow
neither by the arrow's vta_vars nor by the given varmap *)
val vta_filter : varmap -> vty_arrow -> vty_arrow
(* apply a function specification to a variable argument *)
val vta_app : vty_arrow -> pvsymbol -> spec * vty
(* test for ghostness and convert to ghost *)
val vty_ghost : vty -> bool
val vty_ghostify : vty -> vty
(* verify that the spec corresponds to the result type *)
val spec_check : spec -> vty -> unit
(* convert arrows to the unit type *)
val ity_of_vty : vty -> ity
val ty_of_vty : vty -> ty
val vty_vars : vty -> varset
......@@ -637,7 +637,7 @@ type lenv = {
mod_uc : module_uc;
th_at : Theory.theory_uc;
th_old : Theory.theory_uc;
let_vars : let_var Mstr.t;
let_vars : let_sym Mstr.t;
log_vars : vsymbol Mstr.t;
log_denv : Typing.denv;
}
......@@ -664,6 +664,9 @@ let create_post lenv x ty f =
count_term_tuples f;
create_post res f
let create_xpost lenv x xs f = create_post lenv x (ty_of_ity xs.xs_ity) f
let create_post lenv x vty f = create_post lenv x (ty_of_vty vty) f
let create_pre lenv f =
let f = Typing.type_fmla lenv.th_at lenv.log_denv lenv.log_vars f in
count_term_tuples f;
......@@ -695,7 +698,7 @@ let binders lenv bl =
let xpost lenv xq =
let add_exn m (xs,f) =
let f = create_post lenv "result" (ty_of_ity xs.xs_ity) f in
let f = create_xpost lenv "result" xs f in
Mexn.add_new (DuplicateException xs) xs f m in
List.fold_left add_exn Mexn.empty xq
......@@ -778,34 +781,31 @@ let eff_of_deff lenv deff =
eff
let rec type_c lenv gh vars dtyc =
let result = type_v lenv gh vars dtyc.dc_result in
let ty = match result with
| SpecV v -> ty_of_ity v.vtv_ity
| SpecA _ -> ty_unit in
let vty = type_v lenv gh vars dtyc.dc_result in
let eff = eff_of_deff lenv dtyc.dc_effect in
(* reset every new region in the result *)
let eff = match result with
| SpecV v ->
let eff = match vty with
| VTvalue v ->
let rec add_reg r eff =
if reg_occurs r vars then eff else eff_reset (add_ity r.reg_ity eff) r
and add_ity ity eff = Sreg.fold add_reg ity.ity_vars.vars_reg eff in
add_ity v.vtv_ity eff
| SpecA _ -> eff in
| VTarrow _ -> eff in
{ c_pre = create_pre lenv dtyc.dc_pre;
c_effect = eff;
c_result = result;
c_post = create_post lenv "result" ty dtyc.dc_post;
c_xpost = xpost lenv dtyc.dc_xpost; }
c_post = create_post lenv "result" vty dtyc.dc_post;
c_xpost = xpost lenv dtyc.dc_xpost }, vty
and type_v lenv gh vars = function
| DSpecV (ghost,v) ->
let ghost = ghost || gh in
SpecV (vty_value ~ghost (ity_of_dity v))
VTvalue (vty_value ~ghost (ity_of_dity v))
| DSpecA (bl,tyc) ->
let lenv, pvl = binders lenv bl in
let add_pv s pv = vars_union s pv.pv_vtv.vtv_vars in
let vars = List.fold_left add_pv vars pvl in
SpecA (pvl, type_c lenv gh vars tyc)
let spec, vty = type_c lenv gh vars tyc in
VTarrow (vty_arrow pvl ~spec vty)
(* expressions *)
......@@ -855,7 +855,7 @@ and expr_desc lenv loc de = match de.de_desc with
| _ -> ()
end;
let def1 = create_let_defn (Denv.create_user_id x) e1 in
let lenv = add_local x.id def1.let_var lenv in
let lenv = add_local x.id def1.let_sym lenv in
let e2 = expr lenv de2 in
e_let def1 e2
| DEletrec (rdl, de1) ->
......@@ -903,10 +903,7 @@ and expr_desc lenv loc de = match de.de_desc with
e_case e1 (List.map branch bl)
| DEabstract (de1, q, xq) ->
let e1 = expr lenv de1 in
let ty = match e1.e_vty with
| VTvalue v -> ty_of_ity v.vtv_ity
| VTarrow _ -> ty_unit in
let q = create_post lenv "result" ty q in
let q = create_post lenv "result" e1.e_vty q in
e_abstract e1 q (xpost lenv xq)
| DEassert (ak, f) ->
let ak = match ak with
......@@ -933,10 +930,11 @@ and expr_desc lenv loc de = match de.de_desc with
expr lenv { de1 with de_desc = DEtry (de2, bl) }
| DEmark (x, de1) ->
let ld = create_let_defn (Denv.create_user_id x) e_now in
let lenv = add_local x.id ld.let_var lenv in
let lenv = add_local x.id ld.let_sym lenv in
e_let ld (expr lenv de1)
| DEany dtyc ->
e_any (type_c lenv false vars_empty dtyc)
let spec, result = type_c lenv false vars_empty dtyc in
e_any spec result
| DEghost de1 ->
e_ghostify true (expr lenv de1)
| DEloop (var,inv,de1) ->
......@@ -979,14 +977,11 @@ and expr_lam lenv gh (bl, var, p, de, q, xq) =
let e = e_ghostify gh (expr lenv de) in
if not gh && vty_ghost e.e_vty then
errorm ~loc:de.de_loc "ghost body in a non-ghost function";
let ty = match e.e_vty with
| VTvalue vtv -> ty_of_ity vtv.vtv_ity
| VTarrow _ -> ty_unit in
{ l_args = pvl;
l_variant = List.map (create_variant lenv) var;
l_pre = create_pre lenv p;
l_expr = e;
l_post = create_post lenv "result" ty q;
l_post = create_post lenv "result" e.e_vty q;
l_xpost = xpost lenv xq; }
(** Type declaration *)
......@@ -1492,7 +1487,7 @@ let add_module lib path mm mt m =
let tyv, _ = dtype_v (create_denv uc) tyv in
let tyv = type_v (create_lenv uc) gh vars_empty tyv in
let vd = create_val (Denv.create_user_id id) tyv in
begin match vd.val_name with
begin match vd.val_sym with
| LetA { ps_vta = { vta_ghost = true }} when not gh ->
errorm ~loc "%s must be a ghost function" id.id
| LetV { pv_vtv = { vtv_ghost = true }} when not gh ->
......
......@@ -126,198 +126,11 @@ let rec drop_at now m t = match t.t_node with
| _ ->
t_map (drop_at now m) t
(** Specifications *)
let psymbol_spec_t : type_v Wps.t = Wps.create 17
let e_apply_spec_t : type_c Wexpr.t = Wexpr.create 17
let add_pv_varm pv m = Mid.add pv.pv_vs.vs_name pv.pv_vtv.vtv_vars m
let add_pv_vars pv s = vars_union pv.pv_vtv.vtv_vars s
let rec check_spec vty tyv = match vty, tyv with
| VTvalue _, SpecV _ -> ()
| VTarrow vta, SpecA (_::(_::_ as pvl), tyc) ->
assert (eff_is_empty vta.vta_effect);
check_spec vta.vta_result (SpecA (pvl, tyc))
| VTarrow vta, SpecA ([_], tyc) ->
let eff1 = vta.vta_effect in
let eff2 = tyc.c_effect in
assert (Sreg.equal eff1.eff_reads eff2.eff_reads);
assert (Sreg.equal eff1.eff_writes eff2.eff_writes);
assert (Sexn.equal eff1.eff_raises eff2.eff_raises);
assert (Sreg.equal eff1.eff_ghostr eff2.eff_ghostr);
assert (Sreg.equal eff1.eff_ghostw eff2.eff_ghostw);
assert (Sexn.equal eff1.eff_ghostx eff2.eff_ghostx);
check_spec vta.vta_result tyc.c_result
| _ -> assert false
let rec filter_v varm vars = function
| SpecA (pvl, tyc) ->
let varm = List.fold_right add_pv_varm pvl varm in
let vars = List.fold_right add_pv_vars pvl vars in
SpecA (pvl, filter_c varm vars tyc)
| tyv -> tyv
and filter_c varm vars tyc =
let add _ f s = Mvs.set_union f.t_vars s in
let vss = add () tyc.c_pre tyc.c_post.t_vars in
let vss = Mexn.fold add tyc.c_xpost vss in
let check { vs_name = id } _ = if not (Mid.mem id varm) then
Loc.errorm "Local variable %s escapes from its scope" id.id_string in
Mvs.iter check vss;
let result = filter_v varm vars tyc.c_result in
let effect = eff_filter vars tyc.c_effect in
{ tyc with c_effect = effect; c_result = result }
let add_psymbol_spec varm ps tyv =
let vars = Mid.fold (fun _ -> vars_union) varm vars_empty in
let tyv = filter_v varm vars tyv in
if Debug.test_flag debug then
Format.eprintf "@[<hov 2>SPEC %a = %a@]@\n"
Mlw_pretty.print_psty ps Mlw_pretty.print_type_v tyv;
check_spec (VTarrow ps.ps_vta) tyv; (* TODO: prove and remove *)
Wps.set psymbol_spec_t ps tyv
(* TODO? move spec_inst and subst to Mlw_expr? *)
let vtv_full_inst sbs vtv =
vty_value ~ghost:vtv.vtv_ghost (ity_full_inst sbs vtv.vtv_ity)
let pv_full_inst sbs pv =
create_pvsymbol (id_clone pv.pv_vs.vs_name) (vtv_full_inst sbs pv.pv_vtv)