Commit 15fc3d65 authored by Andrei Paskevich's avatar Andrei Paskevich

WhyML: check type invariants

Type declarations for records (incuding the private records) can
now be followed by a "witness": a set of values for the record
fields that must satisfy the type invariant (if any). The fields
must be initialized with pure terminating program expressions.
The current syntax, proposed by Martin, is

    type t 'a = { f: ty1; g: ty2 }
      invariant { J[f,g] }
      by { f = e1; g = e2 }

The generated proof obligation is the VC for

    let g = e2 in let f = e1 in assert { J[f,g] }

In absence of an explicit witness, an existential proof obligation
"exists f,g. J[f,g]" is produced.
parent 5fb8c95f
...@@ -50,6 +50,7 @@ module HashtblImpl ...@@ -50,6 +50,7 @@ module HashtblImpl
invariant { invariant {
forall i: int. 0 <= i < length data -> good_hash data i } forall i: int. 0 <= i < length data -> good_hash data i }
invariant { forall k: key, v: 'a. good_data k v view data } invariant { forall k: key, v: 'a. good_data k v view data }
by { size = 0; data = make 1 Nil; view = Const.const None }
let create (n: int) : t 'a let create (n: int) : t 'a
requires { 1 <= n } requires { 1 <= n }
......
...@@ -23,23 +23,25 @@ type its_defn = { ...@@ -23,23 +23,25 @@ type its_defn = {
itd_fields : rsymbol list; itd_fields : rsymbol list;
itd_constructors : rsymbol list; itd_constructors : rsymbol list;
itd_invariant : term list; itd_invariant : term list;
itd_witness : expr list;
} }
let mk_itd s f c i = { let mk_itd s f c i w = {
itd_its = s; itd_its = s;
itd_fields = f; itd_fields = f;
itd_constructors = c; itd_constructors = c;
itd_invariant = i; itd_invariant = i;
itd_witness = w;
} }
let create_alias_decl id args ity = let create_alias_decl id args ity =
mk_itd (create_alias_itysymbol id args ity) [] [] [] mk_itd (create_alias_itysymbol id args ity) [] [] [] []
let create_range_decl id ir = let create_range_decl id ir =
mk_itd (create_range_itysymbol id ir) [] [] [] mk_itd (create_range_itysymbol id ir) [] [] [] []
let create_float_decl id fp = let create_float_decl id fp =
mk_itd (create_float_itysymbol id fp) [] [] [] mk_itd (create_float_itysymbol id fp) [] [] [] []
let check_field stv f = let check_field stv f =
let loc = f.pv_vs.vs_name.id_loc in let loc = f.pv_vs.vs_name.id_loc in
...@@ -73,7 +75,7 @@ let create_semi_constructor id s fdl pjl invl = ...@@ -73,7 +75,7 @@ let create_semi_constructor id s fdl pjl invl =
let c = create_cty fdl invl [q] Mxs.empty Mpv.empty eff ity in let c = create_cty fdl invl [q] Mxs.empty Mpv.empty eff ity in
create_rsymbol id c create_rsymbol id c
let create_plain_record_decl ~priv ~mut id args fdl invl = let create_plain_record_decl ~priv ~mut id args fdl invl witn =
let exn = Invalid_argument "Pdecl.create_plain_record_decl" in let exn = Invalid_argument "Pdecl.create_plain_record_decl" in
let cid = id_fresh ?loc:id.pre_loc ("mk " ^ id.pre_name) in let cid = id_fresh ?loc:id.pre_loc ("mk " ^ id.pre_name) in
let add_fd fds (mut, fd) = Mpv.add_new exn fd mut fds in let add_fd fds (mut, fd) = Mpv.add_new exn fd mut fds in
...@@ -84,7 +86,17 @@ let create_plain_record_decl ~priv ~mut id args fdl invl = ...@@ -84,7 +86,17 @@ let create_plain_record_decl ~priv ~mut id args fdl invl =
let csl = if priv then [] else if invl <> [] then let csl = if priv then [] else if invl <> [] then
[create_semi_constructor cid s fdl pjl invl] else [create_semi_constructor cid s fdl pjl invl] else
[create_constructor ~constr:1 cid s fdl] in [create_constructor ~constr:1 cid s fdl] in
mk_itd s pjl csl invl if witn <> [] then begin
List.iter2 (fun fd ({e_loc = loc} as e) ->
Loc.try2 ?loc ity_equal_check e.e_ity fd.pv_ity;
if e.e_effect.eff_oneway then Loc.errorm ?loc
"This expression may not terminate, it cannot be a witness";
if not (eff_pure e.e_effect) then Loc.errorm ?loc
"This expression has side effects, it cannot be a witness";
if not fd.pv_ghost && mask_ghost e.e_mask then Loc.errorm ?loc
"Ghost witness for a non-ghost field %a" print_pv fd) fdl witn
end;
mk_itd s pjl csl invl witn
let create_rec_record_decl s fdl = let create_rec_record_decl s fdl =
let exn = Invalid_argument "Pdecl.create_rec_record_decl" in let exn = Invalid_argument "Pdecl.create_rec_record_decl" in
...@@ -94,7 +106,7 @@ let create_rec_record_decl s fdl = ...@@ -94,7 +106,7 @@ let create_rec_record_decl s fdl =
List.iter (check_field (Stv.of_list s.its_ts.ts_args)) fdl; List.iter (check_field (Stv.of_list s.its_ts.ts_args)) fdl;
let cs = create_constructor ~constr:1 cid s fdl in let cs = create_constructor ~constr:1 cid s fdl in
let pjl = List.map (create_projection s) fdl in let pjl = List.map (create_projection s) fdl in
mk_itd s pjl [cs] [] mk_itd s pjl [cs] [] []
let create_variant_decl exn get_its csl = let create_variant_decl exn get_its csl =
(* named projections are the same in each constructor *) (* named projections are the same in each constructor *)
...@@ -114,7 +126,7 @@ let create_variant_decl exn get_its csl = ...@@ -114,7 +126,7 @@ let create_variant_decl exn get_its csl =
(* and now we can create the type symbol and the constructors *) (* and now we can create the type symbol and the constructors *)
let s = get_its (List.map get_fds csl) and constr = List.length csl in let s = get_its (List.map get_fds csl) and constr = List.length csl in
let mk_cs (id, fdl) = create_constructor ~constr id s (List.map snd fdl) in let mk_cs (id, fdl) = create_constructor ~constr id s (List.map snd fdl) in
mk_itd s (List.map (create_projection s) pjl) (List.map mk_cs csl) [] mk_itd s (List.map (create_projection s) pjl) (List.map mk_cs csl) [] []
let create_plain_variant_decl id args csl = let create_plain_variant_decl id args csl =
let exn = Invalid_argument "Pdecl.create_plain_variant_decl" in let exn = Invalid_argument "Pdecl.create_plain_variant_decl" in
...@@ -284,6 +296,7 @@ let get_syms node pure = ...@@ -284,6 +296,7 @@ let get_syms node pure =
let add_fd syms s = syms_ity syms s.rs_cty.cty_result in let add_fd syms s = syms_ity syms s.rs_cty.cty_result in
let add_cs syms s = syms_pvl syms s.rs_cty.cty_args in let add_cs syms s = syms_pvl syms s.rs_cty.cty_args in
let syms = List.fold_left add_fd syms d.itd_fields in let syms = List.fold_left add_fd syms d.itd_fields in
let syms = List.fold_left syms_expr syms d.itd_witness in
List.fold_left add_cs syms d.itd_constructors in List.fold_left add_cs syms d.itd_constructors in
List.fold_left syms_itd syms dl List.fold_left syms_itd syms dl
| PDlet ld -> | PDlet ld ->
...@@ -563,26 +576,26 @@ open Theory ...@@ -563,26 +576,26 @@ open Theory
let pd_int, pd_real, pd_equ = match builtin_theory.th_decls with let pd_int, pd_real, pd_equ = match builtin_theory.th_decls with
| [{td_node = Decl di}; {td_node = Decl dr}; {td_node = Decl de}] -> | [{td_node = Decl di}; {td_node = Decl dr}; {td_node = Decl de}] ->
mk_decl (PDtype [mk_itd its_int [] [] []]) [di], mk_decl (PDtype [mk_itd its_int [] [] [] []]) [di],
mk_decl (PDtype [mk_itd its_real [] [] []]) [dr], mk_decl (PDtype [mk_itd its_real [] [] [] []]) [dr],
mk_decl PDpure [de] mk_decl PDpure [de]
| _ -> assert false | _ -> assert false
let pd_func, pd_func_app = match highord_theory.th_decls with let pd_func, pd_func_app = match highord_theory.th_decls with
| [{td_node = Decl df}; {td_node = Decl da}] -> | [{td_node = Decl df}; {td_node = Decl da}] ->
mk_decl (PDtype [mk_itd its_func [] [] []]) [df], mk_decl (PDtype [mk_itd its_func [] [] [] []]) [df],
mk_decl (PDlet ld_func_app) [da] mk_decl (PDlet ld_func_app) [da]
| _ -> assert false | _ -> assert false
let pd_bool = match bool_theory.th_decls with let pd_bool = match bool_theory.th_decls with
| [{td_node = Decl db}] -> | [{td_node = Decl db}] ->
mk_decl (PDtype [mk_itd its_bool [] [rs_true; rs_false] []]) [db] mk_decl (PDtype [mk_itd its_bool [] [rs_true; rs_false] [] []]) [db]
| _ -> assert false | _ -> assert false
let pd_tuple = Stdlib.Hint.memo 17 (fun n -> let pd_tuple = Stdlib.Hint.memo 17 (fun n ->
match (tuple_theory n).th_decls with match (tuple_theory n).th_decls with
| [{td_node = Decl dt}] -> | [{td_node = Decl dt}] ->
mk_decl (PDtype [mk_itd (its_tuple n) [] [rs_tuple n] []]) [dt] mk_decl (PDtype [mk_itd (its_tuple n) [] [rs_tuple n] [] []]) [dt]
| _ -> assert false) | _ -> assert false)
(** {2 Known identifiers} *) (** {2 Known identifiers} *)
......
...@@ -22,16 +22,18 @@ type its_defn = private { ...@@ -22,16 +22,18 @@ type its_defn = private {
itd_fields : rsymbol list; itd_fields : rsymbol list;
itd_constructors : rsymbol list; itd_constructors : rsymbol list;
itd_invariant : term list; itd_invariant : term list;
itd_witness : expr list;
} }
val create_plain_record_decl : priv:bool -> mut:bool -> val create_plain_record_decl : priv:bool -> mut:bool ->
preid -> tvsymbol list -> (bool * pvsymbol) list -> term list -> its_defn preid -> tvsymbol list -> (bool * pvsymbol) list ->
(** [create_plain_record_decl ~priv ~mut id args fields invl] creates term list -> expr list -> its_defn
a declaration for a non-recursive record type, possibly private (** [create_plain_record_decl ~priv ~mut id args fields invl witn]
and/or mutable. The known record fields are listed with their creates a declaration for a non-recursive record type, possibly
mutability status. The [priv] flag should be set to [true] for private and/or mutable. The known record fields are listed with
private records. The [mut] flag should be set to [true] to mark their mutability status. The [priv] flag should be set to [true]
the new type as mutable even if it has no known mutable fields. for private records. The [mut] flag should be set to [true] to
mark the new type as mutable even if it has no known mutable fields.
This is the case for private mutable records with no known mutable This is the case for private mutable records with no known mutable
fields, as well as for non-private records that have an invariant: fields, as well as for non-private records that have an invariant:
marking such a type as mutable gives every value of this type a marking such a type as mutable gives every value of this type a
...@@ -39,6 +41,8 @@ val create_plain_record_decl : priv:bool -> mut:bool -> ...@@ -39,6 +41,8 @@ val create_plain_record_decl : priv:bool -> mut:bool ->
The [invl] parameter contains the list of invariant formulas that may The [invl] parameter contains the list of invariant formulas that may
only depend on free variables from [fields]. If the type is private, only depend on free variables from [fields]. If the type is private,
then every field occurring in [invl] must have an immutable type. then every field occurring in [invl] must have an immutable type.
The [witn] parameter provides a witness expression for each field
of a plain record type (can be empty if there is no user witness).
Abstract types are considered to be private records with no fields. *) Abstract types are considered to be private records with no fields. *)
val create_rec_record_decl : itysymbol -> pvsymbol list -> its_defn val create_rec_record_decl : itysymbol -> pvsymbol list -> its_defn
......
This diff is collapsed.
...@@ -1449,4 +1449,34 @@ let vc env kn tuc d = match d.pd_node with ...@@ -1449,4 +1449,34 @@ let vc env kn tuc d = match d.pd_node with
let env = mk_env env kn tuc in let env = mk_env env kn tuc in
let fl = vc_rec env (Debug.test_noflag debug_sp) rdl in let fl = vc_rec env (Debug.test_noflag debug_sp) rdl in
List.map2 (fun rd f -> mk_vc_decl kn rd.rec_sym.rs_name f) rdl fl List.map2 (fun rd f -> mk_vc_decl kn rd.rec_sym.rs_name f) rdl fl
| PDtype tdl ->
let add_witness d vcl =
let add_fd (mv,ldl) fd e =
let fd = fd_of_rs fd in
let id = id_clone fd.pv_vs.vs_name in
let ld, v = let_var id ~ghost:fd.pv_ghost e in
Mvs.add fd.pv_vs (t_var v.pv_vs) mv, ld::ldl in
let mv, ldl = List.fold_left2 add_fd
(Mvs.empty, []) d.itd_fields d.itd_witness in
let e = List.fold_right (fun f e ->
let f = vc_expl None Slab.empty expl_type_inv (t_subst mv f) in
let ld, _ = let_var (id_fresh "_") (e_assert Assert f) in
e_let ld e) d.itd_invariant e_void in
let e = List.fold_right e_let ldl e in
let c = c_fun [] [] [] Mxs.empty Mpv.empty e in
let f = vc_fun (mk_env env kn tuc)
(Debug.test_noflag debug_sp) c.c_cty e in
mk_vc_decl kn d.itd_its.its_ts.ts_name f :: vcl in
let add_invariant d vcl =
let vs_of_rs fd = (fd_of_rs fd).pv_vs in
let vl = List.map vs_of_rs d.itd_fields in
let expl f = vc_expl None Slab.empty expl_type_inv f in
let f = t_and_asym_l (List.map expl d.itd_invariant) in
let f = t_exists_close_simp vl [] f in
mk_vc_decl kn d.itd_its.its_ts.ts_name f :: vcl in
let add_itd d vcl =
if d.itd_witness <> [] then add_witness d vcl else
if d.itd_invariant <> [] then add_invariant d vcl else
vcl in
List.fold_right add_itd tdl []
| _ -> [] | _ -> []
...@@ -287,13 +287,17 @@ pure_decl: ...@@ -287,13 +287,17 @@ pure_decl:
(* Type declarations *) (* Type declarations *)
type_decl: type_decl:
| labels(lident_nq) ty_var* typedefn invariant* | labels(lident_nq) ty_var* typedefn invariant* type_witness
{ let (vis, mut), def = $3 in { let (vis, mut), def = $3 in
{ td_ident = $1; td_params = $2; { td_ident = $1; td_params = $2;
td_vis = vis; td_mut = mut; td_vis = vis; td_mut = mut;
td_inv = $4; td_def = def; td_inv = $4; td_wit = $5; td_def = def;
td_loc = floc $startpos $endpos } } td_loc = floc $startpos $endpos } }
type_witness:
| (* epsilon *) { [] }
| BY LEFTBRC field_list1(expr) RIGHTBRC { $3 }
ty_var: ty_var:
| labels(quote_lident) { $1 } | labels(quote_lident) { $1 }
......
...@@ -184,6 +184,7 @@ type type_decl = { ...@@ -184,6 +184,7 @@ type type_decl = {
td_vis : visibility; (* records only *) td_vis : visibility; (* records only *)
td_mut : bool; (* records or abstract types *) td_mut : bool; (* records or abstract types *)
td_inv : invariant; (* records only *) td_inv : invariant; (* records only *)
td_wit : (qualid * expr) list;
td_def : type_def; td_def : type_def;
} }
......
...@@ -869,7 +869,9 @@ let check_public ~loc d name = ...@@ -869,7 +869,9 @@ let check_public ~loc d name =
if d.td_vis <> Public || d.td_mut then if d.td_vis <> Public || d.td_mut then
Loc.errorm ~loc "%s types cannot be abstract, private, or mutable" name; Loc.errorm ~loc "%s types cannot be abstract, private, or mutable" name;
if d.td_inv <> [] then if d.td_inv <> [] then
Loc.errorm ~loc "%s types cannot have invariants" name Loc.errorm ~loc "%s types cannot have invariants" name;
if d.td_wit <> [] then
Loc.errorm ~loc "%s types cannot have witnesses" name
let add_types muc tdl = let add_types muc tdl =
let add m ({td_ident = {id_str = x}; td_loc = loc} as d) = let add m ({td_ident = {id_str = x}; td_loc = loc} as d) =
...@@ -932,14 +934,14 @@ let add_types muc tdl = ...@@ -932,14 +934,14 @@ let add_types muc tdl =
let alg = Mstr.add x (id,args) alg in let alg = Mstr.add x (id,args) alg in
let get_fd nms fd = let get_fd nms fd =
let {id_str = nm; id_loc = loc} = fd.f_ident in let {id_str = nm; id_loc = loc} = fd.f_ident in
let exn = Loc.Located (loc, Loc.Message ("Field " ^
nm ^ " is used more than once in a record")) in
let nms = Sstr.add_new exn nm nms in
let id = create_user_id fd.f_ident in let id = create_user_id fd.f_ident in
let ity = parse ~loc ~alias ~alg fd.f_pty in let ity = parse ~loc ~alias ~alg fd.f_pty in
let ghost = d.td_vis = Abstract || fd.f_ghost in let ghost = d.td_vis = Abstract || fd.f_ghost in
nms, (fd.f_mutable, create_pvsymbol id ~ghost ity) in let pv = create_pvsymbol id ~ghost ity in
let _,fl = Lists.map_fold_left get_fd Sstr.empty fl in let exn = Loc.Located (loc, Loc.Message ("Field " ^
nm ^ " is used more than once in a record")) in
Mstr.add_new exn nm pv nms, (fd.f_mutable, pv) in
let nms,fl = Lists.map_fold_left get_fd Mstr.empty fl in
(* if not (Hstr.mem htd x) then *) (* if not (Hstr.mem htd x) then *)
begin match try Some (Hstr.find hts x) with Not_found -> None with begin match try Some (Hstr.find hts x) with Not_found -> None with
| Some s -> | Some s ->
...@@ -954,8 +956,23 @@ let add_types muc tdl = ...@@ -954,8 +956,23 @@ let add_types muc tdl =
let add_fd m (_, v) = Mstr.add v.pv_vs.vs_name.id_string v m in let add_fd m (_, v) = Mstr.add v.pv_vs.vs_name.id_string v m in
let gvars = List.fold_left add_fd Mstr.empty fl in let gvars = List.fold_left add_fd Mstr.empty fl in
let type_inv f = type_fmla_pure muc gvars Dterm.denv_empty f in let type_inv f = type_fmla_pure muc gvars Dterm.denv_empty f in
let invl = List.map type_inv d.td_inv in let inv = List.map type_inv d.td_inv in
let itd = create_plain_record_decl ~priv ~mut id args fl invl in let add_w m (q,e) =
let v = try match q with
| Qident x -> Mstr.find x.id_str nms
| Qdot _ -> raise Not_found
with Not_found -> Loc.errorm ~loc:(qloc q)
"Unknown field %a" print_qualid q in
let de = dexpr muc denv_empty e in
let dity = snd (Dexpr.dexpr (DEsym (PV v))).de_dvty in
let de = Dexpr.dexpr ?loc:de.de_loc (DEcast (de, dity)) in
Mpv.add v (expr ~keep_loc:true de) m in
let wit = List.fold_left add_w Mpv.empty d.td_wit in
let wit = if d.td_wit = [] then [] else
List.map (fun (_,v) -> try Mpv.find v wit with
| _ -> Loc.errorm ?loc:v.pv_vs.vs_name.Ident.id_loc
"Missing field %s" v.pv_vs.vs_name.id_string) fl in
let itd = create_plain_record_decl ~priv ~mut id args fl inv wit in
Hstr.add hts x itd.itd_its; Hstr.add htd x itd Hstr.add hts x itd.itd_its; Hstr.add htd x itd
end end
| TDrange (lo,hi) -> | TDrange (lo,hi) ->
......
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