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
invariant {
forall i: int. 0 <= i < length data -> good_hash data i }
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
requires { 1 <= n }
......
......@@ -23,23 +23,25 @@ type its_defn = {
itd_fields : rsymbol list;
itd_constructors : rsymbol 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_fields = f;
itd_constructors = c;
itd_invariant = i;
itd_witness = w;
}
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 =
mk_itd (create_range_itysymbol id ir) [] [] []
mk_itd (create_range_itysymbol id ir) [] [] [] []
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 loc = f.pv_vs.vs_name.id_loc in
......@@ -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
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 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
......@@ -84,7 +86,17 @@ let create_plain_record_decl ~priv ~mut id args fdl invl =
let csl = if priv then [] else if invl <> [] then
[create_semi_constructor cid s fdl pjl invl] else
[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 exn = Invalid_argument "Pdecl.create_rec_record_decl" in
......@@ -94,7 +106,7 @@ let create_rec_record_decl s 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 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 =
(* named projections are the same in each constructor *)
......@@ -114,7 +126,7 @@ let create_variant_decl exn get_its csl =
(* 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 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 exn = Invalid_argument "Pdecl.create_plain_variant_decl" in
......@@ -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_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 syms_expr syms d.itd_witness in
List.fold_left add_cs syms d.itd_constructors in
List.fold_left syms_itd syms dl
| PDlet ld ->
......@@ -563,26 +576,26 @@ open Theory
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}] ->
mk_decl (PDtype [mk_itd its_int [] [] []]) [di],
mk_decl (PDtype [mk_itd its_real [] [] []]) [dr],
mk_decl (PDtype [mk_itd its_int [] [] [] []]) [di],
mk_decl (PDtype [mk_itd its_real [] [] [] []]) [dr],
mk_decl PDpure [de]
| _ -> assert false
let pd_func, pd_func_app = match highord_theory.th_decls with
| [{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]
| _ -> assert false
let pd_bool = match bool_theory.th_decls with
| [{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
let pd_tuple = Stdlib.Hint.memo 17 (fun n ->
match (tuple_theory n).th_decls with
| [{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)
(** {2 Known identifiers} *)
......
......@@ -22,16 +22,18 @@ type its_defn = private {
itd_fields : rsymbol list;
itd_constructors : rsymbol list;
itd_invariant : term list;
itd_witness : expr list;
}
val create_plain_record_decl : priv:bool -> mut:bool ->
preid -> tvsymbol list -> (bool * pvsymbol) list -> term list -> its_defn
(** [create_plain_record_decl ~priv ~mut id args fields invl] creates
a declaration for a non-recursive record type, possibly private
and/or mutable. The known record fields are listed with their
mutability status. The [priv] flag should be set to [true] 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.
preid -> tvsymbol list -> (bool * pvsymbol) list ->
term list -> expr list -> its_defn
(** [create_plain_record_decl ~priv ~mut id args fields invl witn]
creates a declaration for a non-recursive record type, possibly
private and/or mutable. The known record fields are listed with
their mutability status. The [priv] flag should be set to [true]
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
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
......@@ -39,6 +41,8 @@ val create_plain_record_decl : priv:bool -> mut:bool ->
The [invl] parameter contains the list of invariant formulas that may
only depend on free variables from [fields]. If the type is private,
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. *)
val create_rec_record_decl : itysymbol -> pvsymbol list -> its_defn
......
......@@ -689,146 +689,6 @@ let clone_pv cl {pv_vs = vs; pv_ity = ity; pv_ghost = ghost} =
let clone_invl cl sm invl =
List.map (fun t -> clone_term cl sm.sm_vs t) invl
let clone_type_record cl s d s' d' =
let id = s.its_ts.ts_name in
let fields' = Hstr.create 16 in
let add_field' rs' = let pj' = fd_of_rs rs' in
Hstr.add fields' pj'.pv_vs.vs_name.id_string rs' in
List.iter add_field' d'.itd_fields;
(* check if fields from former type are also declared in the new type *)
let match_pj rs = let pj = fd_of_rs rs in
let pj_str = pj.pv_vs.vs_name.id_string in
let pj_ity = clone_ity cl pj.pv_ity in
let pj_ght = pj.pv_ghost in
let rs' = try Hstr.find fields' pj_str
with Not_found -> raise (BadInstance id) in
let pj' = fd_of_rs rs' in
let pj'_ity = pj'.pv_ity in
let pj'_ght = pj'.pv_ghost in
if not (ity_equal pj_ity pj'_ity && (pj_ght || not pj'_ght)) then
raise (BadInstance id);
let ls, ls' = ls_of_rs rs, ls_of_rs rs' in
cl.ls_table <- Mls.add ls ls' cl.ls_table;
cl.rs_table <- Mrs.add rs rs' cl.rs_table;
cl.fd_table <- Mpv.add pj pj' cl.fd_table in
List.iter match_pj d.itd_fields;
cl.ts_table <- Mts.add s.its_ts s' cl.ts_table
let clone_type_decl inst cl tdl kn =
let def =
List.fold_left (fun m d -> Mits.add d.itd_its d m) Mits.empty tdl in
let htd = Hits.create 5 in
let vcs = ref ([] : (itysymbol * term) list) in
let rec visit alg ({its_ts = {ts_name = id} as ts} as s) d =
if not (Hits.mem htd s) then
let alg = Sits.add s alg in
let id' = id_clone id in
let cloned = Mts.mem ts inst.mi_ts || Mts.mem ts inst.mi_ty in
let conv_pj v = create_pvsymbol
(id_clone v.pv_vs.vs_name) ~ghost:v.pv_ghost (conv_ity alg v.pv_ity) in
let save_itd itd =
List.iter2 (cl_save_rs cl) d.itd_constructors itd.itd_constructors;
List.iter2 (cl_save_rs cl) d.itd_fields itd.itd_fields;
Hits.add htd s (Some itd) in
(* alias *)
if s.its_def <> NoDef then begin
if cloned then raise (CannotInstantiate id);
let itd = match s.its_def with
| Alias ty -> create_alias_decl id' ts.ts_args (conv_ity alg ty)
| Range ir -> create_range_decl id' ir
| Float ff -> create_float_decl id' ff
| NoDef -> assert false (* never *) in
cl.ts_table <- Mts.add ts itd.itd_its cl.ts_table;
save_itd itd
end else
(* abstract *)
if s.its_private && cloned then begin
begin match Mts.find_opt ts inst.mi_ts with
| Some s' ->
if not (List.length ts.ts_args = List.length s'.its_ts.ts_args) then
raise (BadInstance id);
let pd' = Mid.find s'.its_ts.ts_name kn in
let d' = match pd'.pd_node with
| PDtype [d'] -> d'
(* FIXME: we could refine with mutual types *)
| PDtype _ -> raise (BadInstance id)
| PDlet _ | PDexn _ | PDpure -> raise (BadInstance id) in
clone_type_record cl s d s' d'; (* clone record fields *)
(* generate and add VC for type invariant implication *)
if d.itd_invariant <> [] then begin
let inv = axiom_of_invariant d in
let invl = clone_invl cl (sm_of_cl cl) [inv] in
let add_vc inv = vcs := (d.itd_its, inv) :: !vcs in
List.iter add_vc invl end
| None -> begin match Mts.find_opt ts inst.mi_ty with
| Some ity -> (* creative indentation *)
(* TODO: clone_type_record, axiom_of_invariant *)
(* TODO: should we only allow cloning into ity for
private types with no fields and no invariant? *)
let stv = Stv.of_list ts.ts_args in
if not (Stv.subset (ity_freevars Stv.empty ity) stv &&
its_pure s && ity_immutable ity) then raise (BadInstance id);
cl.ty_table <- Mts.add ts ity cl.ty_table
| None -> assert false end end;
Hits.add htd s None;
(* TODO: check typing conditions for refined record type *)
end else
(* variant *)
if not s.its_mutable && d.itd_constructors <> [] &&
d.itd_invariant = [] then begin
if cloned then raise (CannotInstantiate id);
let conv_fd m fd =
let v = fd_of_rs fd in Mpv.add v (conv_pj v) m in
let fldm = List.fold_left conv_fd Mpv.empty d.itd_fields in
let conv_pj pj = match Mpv.find_opt pj fldm with
| Some pj' -> true, pj' | None -> false, conv_pj pj in
let conv_cs cs =
id_clone cs.rs_name, List.map conv_pj cs.rs_cty.cty_args in
let csl = List.map conv_cs d.itd_constructors in
match Mts.find_opt ts cl.ts_table with
| Some s' ->
let itd = create_rec_variant_decl s' csl in
save_itd itd
| None ->
let itd = create_plain_variant_decl id' ts.ts_args csl in
cl.ts_table <- Mts.add ts itd.itd_its cl.ts_table;
save_itd itd
end else begin
(* flat record *)
if cloned then raise (CannotInstantiate id);
let mfld = Spv.of_list s.its_mfields in
let pjl = List.map fd_of_rs d.itd_fields in
let fdl = List.map (fun v -> Spv.mem v mfld, conv_pj v) pjl in
let inv =
if d.itd_invariant = [] then [] else
let add mv u (_,v) = Mvs.add u.pv_vs v.pv_vs mv in
let mv = List.fold_left2 add Mvs.empty pjl fdl in
List.map (clone_term cl mv) d.itd_invariant in
let itd = create_plain_record_decl id' ts.ts_args
~priv:s.its_private ~mut:s.its_mutable fdl inv in
cl.ts_table <- Mts.add ts itd.itd_its cl.ts_table;
save_itd itd
end
and conv_ity alg ity =
let rec down ity = match ity.ity_node with
| Ityreg {reg_its = s; reg_args = tl}
| Ityapp (s,tl,_) ->
if Sits.mem s alg then begin
if not (Mts.mem s.its_ts cl.ts_table) then
let id = id_clone s.its_ts.ts_name in
let s' = create_rec_itysymbol id s.its_ts.ts_args in
cl.ts_table <- Mts.add s.its_ts s' cl.ts_table
end else Opt.iter (visit alg s) (Mits.find_opt s def);
List.iter down tl
| Ityvar _ -> () in
down ity;
clone_ity cl ity in
Mits.iter (visit Sits.empty) def;
Lists.map_filter (fun d -> Hits.find htd d.itd_its) tdl,
!vcs
let clone_varl cl sm varl = List.map (fun (t,r) ->
clone_term cl sm.sm_vs t, Opt.map (cl_find_ls cl) r) varl
......@@ -993,6 +853,148 @@ and clone_let_defn cl sm ld = match ld with
sm_save_rs cl sm d.rec_sym d'.rec_sym) sm rdl rdl' in
sm, ld
let clone_type_record cl s d s' d' =
let id = s.its_ts.ts_name in
let fields' = Hstr.create 16 in
let add_field' rs' = let pj' = fd_of_rs rs' in
Hstr.add fields' pj'.pv_vs.vs_name.id_string rs' in
List.iter add_field' d'.itd_fields;
(* check if fields from former type are also declared in the new type *)
let match_pj rs = let pj = fd_of_rs rs in
let pj_str = pj.pv_vs.vs_name.id_string in
let pj_ity = clone_ity cl pj.pv_ity in
let pj_ght = pj.pv_ghost in
let rs' = try Hstr.find fields' pj_str
with Not_found -> raise (BadInstance id) in
let pj' = fd_of_rs rs' in
let pj'_ity = pj'.pv_ity in
let pj'_ght = pj'.pv_ghost in
if not (ity_equal pj_ity pj'_ity && (pj_ght || not pj'_ght)) then
raise (BadInstance id);
let ls, ls' = ls_of_rs rs, ls_of_rs rs' in
cl.ls_table <- Mls.add ls ls' cl.ls_table;
cl.rs_table <- Mrs.add rs rs' cl.rs_table;
cl.fd_table <- Mpv.add pj pj' cl.fd_table in
List.iter match_pj d.itd_fields;
cl.ts_table <- Mts.add s.its_ts s' cl.ts_table
let clone_type_decl inst cl tdl kn =
let def =
List.fold_left (fun m d -> Mits.add d.itd_its d m) Mits.empty tdl in
let htd = Hits.create 5 in
let vcs = ref ([] : (itysymbol * term) list) in
let rec visit alg ({its_ts = {ts_name = id} as ts} as s) d =
if not (Hits.mem htd s) then
let alg = Sits.add s alg in
let id' = id_clone id in
let cloned = Mts.mem ts inst.mi_ts || Mts.mem ts inst.mi_ty in
let conv_pj v = create_pvsymbol
(id_clone v.pv_vs.vs_name) ~ghost:v.pv_ghost (conv_ity alg v.pv_ity) in
let save_itd itd =
List.iter2 (cl_save_rs cl) d.itd_constructors itd.itd_constructors;
List.iter2 (cl_save_rs cl) d.itd_fields itd.itd_fields;
Hits.add htd s (Some itd) in
(* alias *)
if s.its_def <> NoDef then begin
if cloned then raise (CannotInstantiate id);
let itd = match s.its_def with
| Alias ty -> create_alias_decl id' ts.ts_args (conv_ity alg ty)
| Range ir -> create_range_decl id' ir
| Float ff -> create_float_decl id' ff
| NoDef -> assert false (* never *) in
cl.ts_table <- Mts.add ts itd.itd_its cl.ts_table;
save_itd itd
end else
(* abstract *)
if s.its_private && cloned then begin
begin match Mts.find_opt ts inst.mi_ts with
| Some s' ->
if not (List.length ts.ts_args = List.length s'.its_ts.ts_args) then
raise (BadInstance id);
let pd' = Mid.find s'.its_ts.ts_name kn in
let d' = match pd'.pd_node with
| PDtype [d'] -> d'
(* FIXME: we could refine with mutual types *)
| PDtype _ -> raise (BadInstance id)
| PDlet _ | PDexn _ | PDpure -> raise (BadInstance id) in
clone_type_record cl s d s' d'; (* clone record fields *)
(* generate and add VC for type invariant implication *)
if d.itd_invariant <> [] then begin
let inv = axiom_of_invariant d in
let invl = clone_invl cl (sm_of_cl cl) [inv] in
let add_vc inv = vcs := (d.itd_its, inv) :: !vcs in
List.iter add_vc invl end
| None -> begin match Mts.find_opt ts inst.mi_ty with
| Some ity -> (* creative indentation *)
(* TODO: clone_type_record, axiom_of_invariant *)
(* TODO: should we only allow cloning into ity for
private types with no fields and no invariant? *)
let stv = Stv.of_list ts.ts_args in
if not (Stv.subset (ity_freevars Stv.empty ity) stv &&
its_pure s && ity_immutable ity) then raise (BadInstance id);
cl.ty_table <- Mts.add ts ity cl.ty_table
| None -> assert false end end;
Hits.add htd s None;
(* TODO: check typing conditions for refined record type *)
end else
(* variant *)
if not s.its_mutable && d.itd_constructors <> [] &&
d.itd_invariant = [] then begin
if cloned then raise (CannotInstantiate id);
let conv_fd m fd =
let v = fd_of_rs fd in Mpv.add v (conv_pj v) m in
let fldm = List.fold_left conv_fd Mpv.empty d.itd_fields in
let conv_pj pj = match Mpv.find_opt pj fldm with
| Some pj' -> true, pj' | None -> false, conv_pj pj in
let conv_cs cs =
id_clone cs.rs_name, List.map conv_pj cs.rs_cty.cty_args in
let csl = List.map conv_cs d.itd_constructors in
match Mts.find_opt ts cl.ts_table with
| Some s' ->
let itd = create_rec_variant_decl s' csl in
save_itd itd
| None ->
let itd = create_plain_variant_decl id' ts.ts_args csl in
cl.ts_table <- Mts.add ts itd.itd_its cl.ts_table;
save_itd itd
end else begin
(* flat record *)
if cloned then raise (CannotInstantiate id);
let mfld = Spv.of_list s.its_mfields in
let pjl = List.map fd_of_rs d.itd_fields in
let fdl = List.map (fun v -> Spv.mem v mfld, conv_pj v) pjl in
let inv =
if d.itd_invariant = [] then [] else
let add mv u (_,v) = Mvs.add u.pv_vs v.pv_vs mv in
let mv = List.fold_left2 add Mvs.empty pjl fdl in
List.map (clone_term cl mv) d.itd_invariant in
let clone_wit = clone_expr cl (sm_of_cl cl) in
let wit = List.map clone_wit d.itd_witness in
let itd = create_plain_record_decl id' ts.ts_args
~priv:s.its_private ~mut:s.its_mutable fdl inv wit in
cl.ts_table <- Mts.add ts itd.itd_its cl.ts_table;
save_itd itd
end
and conv_ity alg ity =
let rec down ity = match ity.ity_node with
| Ityreg {reg_its = s; reg_args = tl}
| Ityapp (s,tl,_) ->
if Sits.mem s alg then begin
if not (Mts.mem s.its_ts cl.ts_table) then
let id = id_clone s.its_ts.ts_name in
let s' = create_rec_itysymbol id s.its_ts.ts_args in
cl.ts_table <- Mts.add s.its_ts s' cl.ts_table
end else Opt.iter (visit alg s) (Mits.find_opt s def);
List.iter down tl
| Ityvar _ -> () in
down ity;
clone_ity cl ity in
Mits.iter (visit Sits.empty) def;
Lists.map_filter (fun d -> Hits.find htd d.itd_its) tdl,
!vcs
let add_vc uc (its, f) =
let {id_string = nm; id_loc = loc} = its.its_ts.ts_name in
let label = Slab.singleton (Ident.create_label ("expl:VC for " ^ nm)) in
......@@ -1000,8 +1002,19 @@ let add_vc uc (its, f) =
let d = create_pure_decl (create_prop_decl Pgoal pr f) in
add_pdecl ~warn:false ~vc:false uc d
let freeze_foreign cl reads =
let frz = Spv.fold (fun v isb ->
if Sid.mem v.pv_vs.vs_name cl.cl_local then isb
else ity_freeze isb v.pv_ity) reads isb_empty in
let frz = Mreg.map (fun ity -> match ity.ity_node with
| Ityreg r -> r | _ -> assert false) frz.isb_reg in
cl.rn_table <- Mreg.set_union cl.rn_table frz
let clone_pdecl inst cl uc d = match d.pd_node with
| PDtype tdl ->
let add_e spv e = Spv.union spv e.e_effect.eff_reads in
let add_d spv d = List.fold_left add_e spv d.itd_witness in
freeze_foreign cl (List.fold_left add_d Spv.empty tdl);
let tdl, vcl = clone_type_decl inst cl tdl uc.muc_known in
if tdl = [] then List.fold_left add_vc uc vcl else
let add uc d = add_pdecl ~warn:false ~vc:false uc d in
......@@ -1051,12 +1064,7 @@ let clone_pdecl inst cl uc d = match d.pd_node with
| LDsym (_,c) -> cty_reads c.c_cty
| LDrec rdl -> List.fold_left (fun spv {rec_rsym = s} ->
Spv.union spv (cty_reads s.rs_cty)) Spv.empty rdl in
let frz = Spv.fold (fun v isb ->
if Sid.mem v.pv_vs.vs_name cl.cl_local then isb
else ity_freeze isb v.pv_ity) reads isb_empty in
let frz = Mreg.map (fun ity -> match ity.ity_node with
| Ityreg r -> r | _ -> assert false) frz.isb_reg in
cl.rn_table <- Mreg.set_union cl.rn_table frz;
freeze_foreign cl reads;
let sm, ld = clone_let_defn cl (sm_of_cl cl) ld in
cl.pv_table <- sm.sm_pv; cl.rs_table <- sm.sm_rs;
add_pdecl ~warn:false ~vc:false uc (create_let_decl ld)
......
......@@ -1449,4 +1449,34 @@ let vc env kn tuc d = match d.pd_node with
let env = mk_env env kn tuc 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
| 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:
(* Type declarations *)
type_decl:
| labels(lident_nq) ty_var* typedefn invariant*
| labels(lident_nq) ty_var* typedefn invariant* type_witness
{ let (vis, mut), def = $3 in
{ td_ident = $1; td_params = $2;
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 } }
type_witness:
| (* epsilon *) { [] }
| BY LEFTBRC field_list1(expr) RIGHTBRC { $3 }
ty_var:
| labels(quote_lident) { $1 }
......
......@@ -184,6 +184,7 @@ type type_decl = {
td_vis : visibility; (* records only *)
td_mut : bool; (* records or abstract types *)
td_inv : invariant; (* records only *)
td_wit : (qualid * expr) list;
td_def : type_def;
}
......
......@@ -869,7 +869,9 @@ let check_public ~loc d name =
if d.td_vis <> Public || d.td_mut then
Loc.errorm ~loc "%s types cannot be abstract, private, or mutable" name;
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 m ({td_ident = {id_str = x}; td_loc = loc} as d) =
......@@ -932,14 +934,14 @@ let add_types muc tdl =
let alg = Mstr.add x (id,args) alg in
let get_fd nms fd =
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 ity = parse ~loc ~alias ~alg fd.f_pty in
let ghost = d.td_vis = Abstract || fd.f_ghost in
nms, (fd.f_mutable, create_pvsymbol id ~ghost ity) in
let _,fl = Lists.map_fold_left get_fd Sstr.empty fl in
let pv = create_pvsymbol id ~ghost ity 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 *)
begin match try Some (Hstr.find hts x) with Not_found -> None with
| Some s ->
......@@ -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 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 invl = List.map type_inv d.td_inv in
let itd = create_plain_record_decl ~priv ~mut id args fl invl in
let inv = List.map type_inv d.td_inv 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
end
| 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