Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

Commit c0696892 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

whyml: back to the KISS principle

Merge specifications into program types, as JCF intended.
parent 14c2c552
...@@ -178,7 +178,7 @@ let letvar_news = function ...@@ -178,7 +178,7 @@ let letvar_news = function
| LetA ps -> check_vars ps.ps_vars; Sid.singleton ps.ps_name | LetA ps -> check_vars ps.ps_vars; Sid.singleton ps.ps_name
let create_let_decl ld = 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_varmap Sid.empty ld.let_expr.e_vars in
let syms = syms_effect syms ld.let_expr.e_effect in let syms = syms_effect syms ld.let_expr.e_effect in
...@@ -207,7 +207,7 @@ let create_rec_decl rdl = ...@@ -207,7 +207,7 @@ let create_rec_decl rdl =
mk_decl (PDrec rdl) (*syms*) news mk_decl (PDrec rdl) (*syms*) news
let create_val_decl vd = 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_type_v Sid.empty vd.val_spec in
let syms = syms_varmap syms vd.val_vars in let syms = syms_varmap syms vd.val_vars in
......
...@@ -202,8 +202,9 @@ let unify d1 d2 = unify ~weak:false d1 d2 ...@@ -202,8 +202,9 @@ let unify d1 d2 = unify ~weak:false d1 d2
type dvty = dity list * dity (* A -> B -> C == ([A;B],C) *) type dvty = dity list * dity (* A -> B -> C == ([A;B],C) *)
let vty_of_dvty (argl,res) = let vty_of_dvty (argl,res) =
let add a v = VTarrow (vty_arrow (vty_value (ity_of_dity a)) v) in let vtv = VTvalue (vty_value (ity_of_dity res)) in
List.fold_right add argl (VTvalue (vty_value (ity_of_dity res))) 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 type tvars = dity list
...@@ -284,14 +285,14 @@ let specialize_xsymbol xs = ...@@ -284,14 +285,14 @@ let specialize_xsymbol xs =
let specialize_vtarrow vars vta = let specialize_vtarrow vars vta =
let htv = Htv.create 3 and hreg = Hreg.create 3 in 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 rec specialize a =
let arg = conv a.vta_arg in let argl = List.map conv a.vta_args in
let argl,res = match a.vta_result with let narg,res = match a.vta_result with
| VTvalue v -> [], conv v | VTvalue v -> [], dity_of_vtv htv hreg vars v
| VTarrow a -> specialize a | VTarrow a -> specialize a
in in
arg::argl, res argl @ narg, res
in in
specialize vta specialize vta
......
...@@ -27,39 +27,6 @@ open Term ...@@ -27,39 +27,6 @@ open Term
open Mlw_ty open Mlw_ty
open Mlw_ty.T open Mlw_ty.T
(** program variables *)
type pvsymbol = {
pv_vs : vsymbol;
pv_vtv : vty_value;
}
module PVsym = WeakStructMake (struct
type t = pvsymbol
let tag pv = pv.pv_vs.vs_name.id_tag
end)
module Spv = PVsym.S
module Mpv = PVsym.M
module Hpv = PVsym.H
module Wpv = PVsym.W
let pv_equal : pvsymbol -> pvsymbol -> bool = (==)
let create_pvsymbol id vtv = {
pv_vs = create_vsymbol id (ty_of_ity vtv.vtv_ity);
pv_vtv = vtv;
}
let create_pvsymbol, restore_pv =
let vs_to_pv = Wvs.create 17 in
(fun id vtv ->
let pv = create_pvsymbol id vtv in
Wvs.set vs_to_pv pv.pv_vs pv;
pv),
(fun vs -> try Wvs.find vs_to_pv vs with Not_found ->
Loc.error ?loc:vs.vs_name.id_loc (Decl.UnboundVar vs))
(** program symbols *) (** program symbols *)
type psymbol = { type psymbol = {
...@@ -69,29 +36,19 @@ type psymbol = { ...@@ -69,29 +36,19 @@ type psymbol = {
ps_subst : ity_subst; ps_subst : ity_subst;
} }
module PSsym = WeakStructMake (struct
type t = psymbol
let tag ps = ps.ps_name.id_tag
end)
module Sps = PSsym.S
module Mps = PSsym.M
module Hps = PSsym.H
module Wps = PSsym.W
let ps_equal : psymbol -> psymbol -> bool = (==) let ps_equal : psymbol -> psymbol -> bool = (==)
let create_psymbol_real ~poly id vta vars = let create_psymbol_real ~poly id vta varm =
let frozen = if poly then vars else vars_union vars vta.vta_vars let vars = if poly then vars_empty else vta.vta_vars in
in { let vars = vars_merge varm vars in
ps_name = id_register id; { ps_name = id_register id;
ps_vta = vta_filter vars vta; ps_vta = vta_filter varm vta;
ps_vars = frozen; ps_vars = vars;
ps_subst = vars_freeze frozen; } ps_subst = vars_freeze vars; }
let create_psymbol_poly = create_psymbol_real ~poly:true let create_psymbol_poly = create_psymbol_real ~poly:true
let create_psymbol_mono = create_psymbol_real ~poly:false let create_psymbol_mono = create_psymbol_real ~poly:false
let create_psymbol id vta = create_psymbol_poly id vta vars_empty let create_psymbol id vta = create_psymbol_poly id vta Mid.empty
(** program/logic symbols *) (** program/logic symbols *)
...@@ -133,30 +90,14 @@ exception HiddenPLS of lsymbol ...@@ -133,30 +90,14 @@ exception HiddenPLS of lsymbol
(** specification *) (** specification *)
type pre = term (* precondition: pre_fmla *) type let_sym =
type post = term (* postcondition: eps result . post_fmla *)
type xpost = post Mexn.t (* exceptional postconditions *)
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 =
| LetV of pvsymbol | LetV of pvsymbol
| LetA of psymbol | LetA of psymbol
type val_decl = { type val_decl = {
val_name : let_var; val_sym : let_sym;
val_spec : type_v; val_vty : vty;
val_vars : varset Mid.t; val_vars : varmap;
} }
type variant = { type variant = {
...@@ -164,32 +105,12 @@ type variant = { ...@@ -164,32 +105,12 @@ type variant = {
v_rel : lsymbol option; (* tau tau : prop *) v_rel : lsymbol option; (* tau tau : prop *)
} }
let create_post vs f = t_eps_close vs f
let open_post f = match f.t_node with
| Teps bf -> t_open_bound bf
| _ -> Loc.errorm "invalid post-condition"
let check_post f = match f.t_node with
| Teps _ -> ()
| _ -> Loc.errorm "invalid post-condition"
let varmap_join = Mid.fold (fun _ -> vars_union)
let varmap_union = Mid.set_union
let add_pv_vars pv m = Mid.add pv.pv_vs.vs_name pv.pv_vtv.vtv_vars m let add_pv_vars pv m = Mid.add pv.pv_vs.vs_name pv.pv_vtv.vtv_vars m
let add_vs_vars vs m = add_pv_vars (restore_pv vs) m let add_vs_vars vs m = add_pv_vars (restore_pv vs) m
let fmla_vars f vsset = let pre_vars f vsset = Mvs.set_union vsset f.t_vars
if f.t_ty <> None then Loc.error ?loc:f.t_loc (FmlaExpected f); let post_vars f vsset = Mvs.set_union vsset f.t_vars
Mvs.set_union vsset f.t_vars let xpost_vars = Mexn.fold (fun _ -> post_vars)
let post_vars ity f vsset =
check_post f;
Ty.ty_equal_check (ty_of_ity ity) (t_type f);
Mvs.set_union vsset f.t_vars
let xpost_vars = Mexn.fold (fun xs -> post_vars xs.xs_ity)
let variant_vars varl vsset = let variant_vars varl vsset =
let add_variant s { v_term = t; v_rel = ps } = let add_variant s { v_term = t; v_rel = ps } =
...@@ -201,52 +122,32 @@ let variant_vars varl vsset = ...@@ -201,52 +122,32 @@ let variant_vars varl vsset =
Mvs.set_union s t.t_vars in Mvs.set_union s t.t_vars in
List.fold_left add_variant vsset varl List.fold_left add_variant vsset varl
exception UnboundException of xsymbol let spec_varmap varm variant spec =
let vsset = pre_vars spec.c_pre Mvs.empty in
let spec_vars varm variant pre post xpost eff result = let vsset = post_vars spec.c_post vsset in
let vsset = fmla_vars pre Mvs.empty in let vsset = xpost_vars spec.c_xpost vsset in
let vsset = post_vars result post vsset in
let vsset = xpost_vars xpost vsset in
let vsset = variant_vars variant vsset in let vsset = variant_vars variant vsset in
let badex = Sexn.union eff.eff_raises eff.eff_ghostx in
let badex = Mexn.set_diff badex xpost in
if not (Sexn.is_empty badex) then
raise (UnboundException (Sexn.choose badex));
Mvs.fold (fun vs _ m -> add_vs_vars vs m) vsset varm Mvs.fold (fun vs _ m -> add_vs_vars vs m) vsset varm
exception DuplicateArg of pvsymbol let rec vta_varmap vta =
let varm = vty_varmap vta.vta_result in
let spec_arrow pvl effect vty = let varm = spec_varmap varm [] vta.vta_spec in
let add pv s = Spv.add_new (DuplicateArg pv) pv s in let del_pv m pv = Mid.remove pv.pv_vs.vs_name m in
ignore (List.fold_right add pvl Spv.empty); List.fold_left del_pv varm vta.vta_args
let arg,argl = match List.rev pvl with
| [] -> Loc.errorm "Empty argument list" and vty_varmap = function
| arg::argl -> arg, argl in | VTarrow a -> vta_varmap a
let vta = vty_arrow arg.pv_vtv ~effect vty in | VTvalue _ -> Mid.empty
let add_arg vta pv = vty_arrow pv.pv_vtv (VTarrow vta) in
List.fold_left add_arg vta argl
let rec check_c tyc =
let varm = check_v tyc.c_result in
let result = match tyc.c_result with
| SpecV v -> v.vtv_ity
| SpecA _ -> ity_unit in
spec_vars varm [] tyc.c_pre tyc.c_post tyc.c_xpost tyc.c_effect result
and check_v = function
| SpecV _ -> Mid.empty
| SpecA (pvl,tyc) ->
let del_pv m pv = Mid.remove pv.pv_vs.vs_name m in
List.fold_left del_pv (check_c tyc) pvl
let eff_check vars result e = let eff_check vars result e =
let check r = let check r =
if not (reg_occurs r vars) then if not (reg_occurs r vars) then
Loc.errorm "every external effect must be covered in a post-condition" Loc.errorm "every external effect must be mentioned in specification"
in in
let reset r u = match result with let reset r u = match result with
(* FIXME: we must reset non-written subregions of written regions *)
| _ when u <> None -> Loc.errorm "abstract parameters cannot reset regions" | _ when u <> None -> Loc.errorm "abstract parameters cannot reset regions"
| SpecV v when reg_occurs r v.vtv_vars -> () | VTvalue v when reg_occurs r v.vtv_vars -> ()
| _ -> check r | _ -> check r
in in
Sreg.iter check e.eff_reads; Sreg.iter check e.eff_reads;
...@@ -255,28 +156,27 @@ let eff_check vars result e = ...@@ -255,28 +156,27 @@ let eff_check vars result e =
Sreg.iter check e.eff_ghostw; Sreg.iter check e.eff_ghostw;
Mreg.iter reset e.eff_resets Mreg.iter reset e.eff_resets
let rec build_c vars tyc = let rec vta_check vars vta =
let vty = build_v vars tyc.c_result in let add_arg vars pv = vars_union vars pv.pv_vtv.vtv_vars in
eff_check vars tyc.c_result tyc.c_effect; let vars = List.fold_left add_arg vars vta.vta_args in
vty eff_check vars vta.vta_result vta.vta_spec.c_effect;
vty_check vars vta.vta_result
and build_v vars = function
| SpecV vtv -> and vty_check vars = function
if vtv.vtv_mut <> None then | VTarrow a -> vta_check vars a
Loc.errorm "abstract parameters cannot produce mutable values"; | VTvalue v -> if v.vtv_mut <> None then
VTvalue vtv Loc.errorm "abstract parameters cannot produce mutable values"
| SpecA (pvl,tyc) ->
let add_arg vars pv = vars_union vars pv.pv_vtv.vtv_vars in let create_val id vty = match vty with
let vty = build_c (List.fold_left add_arg vars pvl) tyc in | VTvalue v ->
VTarrow (spec_arrow pvl tyc.c_effect vty) let pv = create_pvsymbol id v in
vty_check vars_empty vty;
let create_val id tyv = { val_sym = LetV pv; val_vty = vty; val_vars = Mid.empty }
let varm = check_v tyv in | VTarrow a ->
let vars = varmap_join varm vars_empty in let varm = vta_varmap a in
let name = match build_v vars tyv with let ps = create_psymbol_poly id a varm in
| VTarrow vta -> LetA (create_psymbol_poly id vta vars) vta_check ps.ps_vars a;
| VTvalue vtv -> LetV (create_pvsymbol id vtv) in { val_sym = LetA ps; val_vty = vty; val_vars = varm }
{ val_name = name; val_spec = tyv; val_vars = varm }
(** patterns *) (** patterns *)
...@@ -461,24 +361,23 @@ type expr = { ...@@ -461,24 +361,23 @@ type expr = {
e_node : expr_node; e_node : expr_node;
e_vty : vty; e_vty : vty;
e_effect : effect; e_effect : effect;
e_vars : varset Mid.t; e_vars : varmap;
e_label : Slab.t; e_label : Slab.t;
e_loc : Loc.position option; e_loc : Loc.position option;
e_tag : Hashweak.tag;
} }
and expr_node = and expr_node =
| Elogic of term | Elogic of term
| Evalue of pvsymbol | Evalue of pvsymbol
| Earrow of psymbol | Earrow of psymbol
| Eapp of expr * pvsymbol | Eapp of expr * pvsymbol * spec
| Elet of let_defn * expr | Elet of let_defn * expr
| Erec of rec_defn list * expr | Erec of rec_defn list * expr
| Eif of expr * expr * expr | Eif of expr * expr * expr
| Ecase of expr * (ppattern * expr) list | Ecase of expr * (ppattern * expr) list
| Eassign of expr * region * pvsymbol | Eassign of expr * region * pvsymbol
| Eghost of expr | Eghost of expr
| Eany of type_c | Eany of spec
| Eloop of invariant * variant list * expr | Eloop of invariant * variant list * expr
| Efor of pvsymbol * for_bounds * invariant * expr | Efor of pvsymbol * for_bounds * invariant * expr
| Eraise of xsymbol * expr | Eraise of xsymbol * expr
...@@ -488,14 +387,14 @@ and expr_node = ...@@ -488,14 +387,14 @@ and expr_node =
| Eabsurd | Eabsurd
and let_defn = { and let_defn = {
let_var : let_var; let_sym : let_sym;
let_expr : expr; let_expr : expr;
} }
and rec_defn = { and rec_defn = {
rec_ps : psymbol; rec_ps : psymbol;
rec_lambda : lambda; rec_lambda : lambda;
rec_vars : varset Mid.t; rec_vars : varmap;
} }
and lambda = { and lambda = {
...@@ -507,16 +406,6 @@ and lambda = { ...@@ -507,16 +406,6 @@ and lambda = {
l_xpost : xpost; l_xpost : xpost;
} }
module WSexpr = WeakStructMake (struct
type t = expr
let tag expr = expr.e_tag
end)
module Sexpr = WSexpr.S
module Mexpr = WSexpr.M
module Hexpr = WSexpr.H
module Wexpr = WSexpr.W
(* smart constructors *) (* smart constructors *)
let e_label ?loc l e = { e with e_label = l; e_loc = loc } let e_label ?loc l e = { e with e_label = l; e_loc = loc }
...@@ -531,23 +420,16 @@ let e_label_copy { e_label = lab; e_loc = loc } e = ...@@ -531,23 +420,16 @@ let e_label_copy { e_label = lab; e_loc = loc } e =
exception GhostWrite of expr * region exception GhostWrite of expr * region
exception GhostRaise of expr * xsymbol exception GhostRaise of expr * xsymbol
let mk_expr node vty eff vars c = { let mk_expr node vty eff vars = {
e_node = node; e_node = node;
e_vty = vty; e_vty = vty;
e_effect = if vty_ghost vty then eff_ghostify eff else eff; e_effect = if vty_ghost vty then eff_ghostify eff else eff;
e_vars = vars; e_vars = vars;
e_label = Slab.empty; e_label = Slab.empty;
e_loc = None; e_loc = None;
e_tag = Hashweak.create_tag c;
} }
let mk_expr = let varmap_union = Mid.set_union
let c = ref 0 in fun node vty eff vars ->
incr c; mk_expr node vty eff vars !c
(* FIXME? e_label calls do not refresh the tag. This is safe
as long as we only use tags for "semantical things" such as
extended specification storage in WPs. *)
let add_t_vars t m = Mvs.fold (fun vs _ m -> add_vs_vars vs m) t.t_vars m let add_t_vars t m = Mvs.fold (fun vs _ m -> add_vs_vars vs m) t.t_vars m
let add_e_vars e m = varmap_union e.e_vars m let add_e_vars e m = varmap_union e.e_vars m
...@@ -577,10 +459,9 @@ let create_let_defn id e = ...@@ -577,10 +459,9 @@ let create_let_defn id e =
| VTvalue vtv -> | VTvalue vtv ->
LetV (create_pvsymbol id (vtv_unmut vtv)) LetV (create_pvsymbol id (vtv_unmut vtv))
| VTarrow vta -> | VTarrow vta ->
let vars = varmap_join e.e_vars vars_empty in LetA (create_psymbol_mono id vta e.e_vars)
LetA (create_psymbol_mono id vta vars)
in in
{ let_var = lv ; let_expr = e } { let_sym = lv ; let_expr = e }
exception StaleRegion of expr * region * ident exception StaleRegion of expr * region * ident
...@@ -615,7 +496,7 @@ let check_postexpr e eff vars = ...@@ -615,7 +496,7 @@ let check_postexpr e eff vars =
check_ghost_write e eff; check_ghost_write e eff;
check_reset e vars check_reset e vars
let e_let ({ let_var = lv ; let_expr = d } as ld) e = let e_let ({ let_sym = lv ; let_expr = d } as ld) e =
let id = match lv with let id = match lv with
| LetV pv -> pv.pv_vs.vs_name | LetV pv -> pv.pv_vs.vs_name
| LetA ps -> ps.ps_name in | LetA ps -> ps.ps_name in
...@@ -625,24 +506,23 @@ let e_let ({ let_var = lv ; let_expr = d } as ld) e = ...@@ -625,24 +506,23 @@ let e_let ({ let_var = lv ; let_expr = d } as ld) e =
mk_expr (Elet (ld,e)) e.e_vty eff (add_e_vars d vars) mk_expr (Elet (ld,e)) e.e_vty eff (add_e_vars d vars)
let e_app_real e pv = let e_app_real e pv =
let eff,vty = vty_app_arrow (vta_of_expr e) pv.pv_vtv in let spec,vty = vta_app (vta_of_expr e) pv in
check_postexpr e eff (add_pv_vars pv Mid.empty); check_postexpr e spec.c_effect (add_pv_vars pv Mid.empty);
let eff = eff_union e.e_effect eff in let eff = eff_union e.e_effect spec.c_effect in
mk_expr (Eapp (e,pv)) vty eff (add_pv_vars pv e.e_vars) mk_expr (Eapp (e,pv,spec)) vty eff (add_pv_vars pv e.e_vars)
let create_fun_defn id lam = let create_fun_defn id lam =
let e = lam.l_expr in let e = lam.l_expr in
let result = match e.e_vty with let spec = {
| VTvalue v -> v.vtv_ity c_pre = lam.l_pre;
| VTarrow _ -> ity_unit in c_post = lam.l_post;
let varm = spec_vars e.e_vars lam.l_variant c_xpost = lam.l_xpost;
lam.l_pre lam.l_post lam.l_xpost e.e_effect result in c_effect = e.e_effect; } in
let varm = spec_varmap e.e_vars lam.l_variant spec in
let del_pv m pv = Mid.remove pv.pv_vs.vs_name m in let del_pv m pv = Mid.remove pv.pv_vs.vs_name m in
let varm = List.fold_left del_pv varm lam.l_args in let varm = List.fold_left del_pv varm lam.l_args in
let vars = varmap_join varm vars_empty in let vta = vty_arrow lam.l_args ~spec e.e_vty in
let vta = spec_arrow lam.l_args e.e_effect e.e_vty in { rec_ps = create_psymbol_poly id vta varm;
(* construct rec_defn *)
{ rec_ps = create_psymbol_poly id vta vars;
rec_lambda = lam; rec_lambda = lam;
rec_vars = varm; } rec_vars = varm; }
...@@ -657,7 +537,7 @@ let on_value fn e = match e.e_node with ...@@ -657,7 +537,7 @@ let on_value fn e = match e.e_node with
| Evalue pv -> fn pv | Evalue pv -> fn pv
| _ -> | _ ->
let ld = create_let_defn (id_fresh "o") e in let ld = create_let_defn (id_fresh "o") e in
let pv = match ld.let_var with let pv = match ld.let_sym with
| LetA _ -> Loc.error ?loc:e.e_loc (ValueExpected e) | LetA _ -> Loc.error ?loc:e.e_loc (ValueExpected e)
| LetV pv -> pv in | LetV pv -> pv in
e_let ld (fn pv) e_let ld (fn pv)
...@@ -807,10 +687,13 @@ let e_assign me e = on_value (e_assign_real me) e ...@@ -807,10 +687,13 @@ let e_assign me e = on_value (e_assign_real me) e
let e_ghost e = let e_ghost e =
mk_expr (Eghost e) (vty_ghostify e.e_vty) e.e_effect e.e_vars mk_expr (Eghost e) (vty_ghostify e.e_vty) e.e_effect e.e_vars
let e_any tyc = let e_any spec vty =
let varm = check_c tyc in let varm = spec_varmap (vty_varmap vty) [] spec in
let vars = varmap_join varm vars_empty in let vars = vars_merge varm vars_empty in
mk_expr (Eany tyc) (build_c vars tyc) tyc.c_effect varm spec_check spec vty;
eff_check vars vty spec.c_effect;
vty_check vars vty;
mk_expr (Eany spec) vty spec.c_effect varm
let e_const t = let e_const t =