Skip to content

GitLab

why3
why3
Commit e5ded412 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files
Options

Dexpr: do not use patterns in postconditions 

Instead, pass the optional vsymbol representing the result.
Now formulas-under-patterns do not need to be typechecked
separately, so the previous commit is partially reverted.
parent 33f4683c
Hide whitespace changes
Inline Side-by-side
Showing with 139 additions and 183 deletions
src/core/dterm.ml
View file @ e5ded412
......@@ -406,7 +406,7 @@ let rec term ~strict ~keep_loc uloc env prop dt =
let tloc = if keep_loc then dt.dt_loc else None in
let tloc = if uloc <> None then uloc else tloc in
let t = Loc.try7 ?loc:dt.dt_loc
try_expr strict keep_loc uloc env prop dt.dt_dty dt.dt_node in
try_term strict keep_loc uloc env prop dt.dt_dty dt.dt_node in
let t = t_label tloc labs t in
match t.t_ty with
| Some _ when prop -> t_label tloc Slab.empty
......@@ -415,7 +415,7 @@ let rec term ~strict ~keep_loc uloc env prop dt =
(t_if t t_bool_true t_bool_false)
| _ -> t
and try_expr strict keep_loc uloc env prop dty node =
and try_term strict keep_loc uloc env prop dty node =
let get env prop dt = term ~strict ~keep_loc uloc env prop dt in
match node with
| DTvar (n,_) ->
......@@ -450,8 +450,12 @@ and try_expr strict keep_loc uloc env prop dty node =
(get env prop dt1) (get env prop dt2)
| DTcase (dt,bl) ->
let prop = prop || dty = None in
let mk_b b = branch ~strict ~keep_loc uloc env prop b in
t_case_close (get env false dt) (List.map mk_b bl)
let branch (dp,dt) =
let env, p = pattern ~strict env dp in
let t = get env prop dt in
Svs.iter (check_used_var t.t_vars) p.pat_vars;
t_close_branch p t in
t_case (get env false dt) (List.map branch bl)
| DTeps (id,dty,df) ->
let v = create_vsymbol id (var_ty_of_dty id ~strict dty) in
let env = Mstr.add id.pre_name v env in
......@@ -477,21 +481,9 @@ and try_expr strict keep_loc uloc env prop dty node =
| DTcast _ | DTuloc _ | DTlabel _ ->
assert false (* already stripped *)
and branch ~strict ~keep_loc uloc env prop (dp,dt) =
let env, p = pattern ~strict env dp in
let t = term ~strict ~keep_loc uloc env prop dt in
Svs.iter (check_used_var t.t_vars) p.pat_vars;
p, t
let fmla ~strict ~keep_loc dt = term ~strict ~keep_loc None Mstr.empty true dt
let term ~strict ~keep_loc dt = term ~strict ~keep_loc None Mstr.empty false dt
let term_branch ~strict ~keep_loc dp dt =
branch ~strict ~keep_loc None Mstr.empty false (dp,dt)
let fmla_branch ~strict ~keep_loc dp dt =
branch ~strict ~keep_loc None Mstr.empty true (dp,dt)
(** Exception printer *)
let () = Exn_printer.register (fun fmt e -> match e with
......
src/core/dterm.mli
View file @ e5ded412
......@@ -94,10 +94,5 @@ val dterm : ?loc:Loc.position -> dterm_node -> dterm
(** Final stage *)
val term : strict:bool -> keep_loc:bool -> dterm -> term
val fmla : strict:bool -> keep_loc:bool -> dterm -> term
val term_branch :
strict:bool -> keep_loc:bool -> dpattern -> dterm -> pattern * term
val fmla_branch :
strict:bool -> keep_loc:bool -> dpattern -> dterm -> pattern * term
val fmla : strict:bool -> keep_loc:bool -> dterm -> term
src/parser/typing.ml
View file @ e5ded412
......@@ -45,8 +45,12 @@ let add_prop_decl uc k p f = add_decl_with_tuples uc (create_prop_decl k p f)
(** symbol lookup *)
let rec qloc = function
| Qident x -> x.id_loc
| Qdot (m, x) -> Loc.join (qloc m) x.id_loc
| Qdot (p, id) -> Loc.join (qloc p) id.id_loc
| Qident id -> id.id_loc
let rec print_qualid fmt = function
| Qdot (p, id) -> Format.fprintf fmt "%a.%s" print_qualid p id.id
| Qident id -> Format.fprintf fmt "%s" id.id
let string_list_of_qualid q =
let rec sloq acc = function
......@@ -54,51 +58,43 @@ let string_list_of_qualid q =
| Qident id -> id.id :: acc in
sloq [] q
let rec print_qualid fmt = function
| Qident s -> Format.fprintf fmt "%s" s.id
| Qdot (m, s) -> Format.fprintf fmt "%a.%s" print_qualid m s.id
exception UnboundSymbol of qualid
let find_ns get_id find q ns =
let find_qualid get_id find ns q =
let sl = string_list_of_qualid q in
let r = try find ns sl with Not_found ->
Loc.error ~loc:(qloc q) (UnboundSymbol q) in
if Debug.test_flag Glob.flag then Glob.use (qloc q) (get_id r);
r
let find_prop_ns q ns = find_ns (fun pr -> pr.pr_name) ns_find_pr q ns
let find_tysymbol_ns q ns = find_ns (fun ts -> ts.ts_name) ns_find_ts q ns
let find_lsymbol_ns q ns = find_ns (fun ls -> ls.ls_name) ns_find_ls q ns
let find_prop_ns ns q = find_qualid (fun pr -> pr.pr_name) ns_find_pr ns q
let find_tysymbol_ns ns q = find_qualid (fun ts -> ts.ts_name) ns_find_ts ns q
let find_lsymbol_ns ns q = find_qualid (fun ls -> ls.ls_name) ns_find_ls ns q
let find_fsymbol_ns q ns =
let ls = find_lsymbol_ns q ns in
let find_fsymbol_ns ns q =
let ls = find_lsymbol_ns ns q in
if ls.ls_value <> None then ls else
Loc.error ~loc:(qloc q) (FunctionSymbolExpected ls)
let find_psymbol_ns q ns =
let ls = find_lsymbol_ns q ns in
let find_psymbol_ns ns q =
let ls = find_lsymbol_ns ns q in
if ls.ls_value = None then ls else
Loc.error ~loc:(qloc q) (PredicateSymbolExpected ls)
let find_prop q uc = find_prop_ns q (get_namespace uc)
let find_tysymbol q uc = find_tysymbol_ns q (get_namespace uc)
let find_lsymbol q uc = find_lsymbol_ns q (get_namespace uc)
let find_fsymbol q uc = find_fsymbol_ns q (get_namespace uc)
let find_psymbol q uc = find_psymbol_ns q (get_namespace uc)
let find_prop uc q = find_prop_ns (get_namespace uc) q
let find_tysymbol uc q = find_tysymbol_ns (get_namespace uc) q
let find_lsymbol uc q = find_lsymbol_ns (get_namespace uc) q
let find_fsymbol uc q = find_fsymbol_ns (get_namespace uc) q
let find_psymbol uc q = find_psymbol_ns (get_namespace uc) q
let find_namespace_ns q ns =
find_ns (fun _ -> Glob.dummy_id) ns_find_ns q ns
(* dead code
let find_namespace q uc = find_namespace_ns q (get_namespace uc)
*)
let find_namespace_ns ns q =
find_qualid (fun _ -> Glob.dummy_id) ns_find_ns ns q
(** Parsing types *)
let create_user_tv =
let hs = Hstr.create 17 in
fun s -> try Hstr.find hs s with Not_found ->
let hs = Hstr.create 17 in fun s ->
try Hstr.find hs s with Not_found ->
let tv = create_tvsymbol (id_fresh s) in
Hstr.add hs s tv;
tv
......@@ -110,10 +106,10 @@ let ty_of_pty_top ~noop uc pty =
allowed@ in@ function@ and@ predicate@ prototypes"
| PPTtyvar ({id = x}, _) ->
ty_var (create_user_tv x)
| PPTtyapp (x, tyl) ->
let ts = find_tysymbol x uc in
| PPTtyapp (q, tyl) ->
let ts = find_tysymbol uc q in
let tyl = List.map get_ty tyl in
Loc.try2 ~loc:(qloc x) ty_app ts tyl
Loc.try2 ~loc:(qloc q) ty_app ts tyl
| PPTtuple tyl ->
let ts = ts_tuple (List.length tyl) in
ty_app ts (List.map get_ty tyl)
......@@ -147,15 +143,14 @@ let opaque_tvs args =
(** Typing patterns, terms, and formulas *)
let create_user_id { id = x ; id_lab = ll ; id_loc = loc } =
let get_labels (ll,p) = function
| Lstr l -> Slab.add l ll, p
| Lpos p -> ll, Some p in
let label,p = List.fold_left get_labels (Slab.empty,None) ll in
id_user ~label x (Opt.get_def loc p)
let create_user_id {id = n; id_lab = label; id_loc = loc} =
let get_labels (label, loc) = function
| Lstr lab -> Slab.add lab label, loc | Lpos loc -> label, loc in
let label,loc = List.fold_left get_labels (Slab.empty,loc) label in
id_user ~label n loc
let parse_record ~loc uc get_val fl =
let fl = List.map (fun (q,e) -> find_lsymbol q uc, e) fl in
let fl = List.map (fun (q,e) -> find_lsymbol uc q, e) fl in
let cs,pjl,flm = Loc.try2 ~loc parse_record (get_known uc) fl in
let get_val pj = get_val cs pj (Mls.find_opt pj flm) in
cs, List.map get_val pjl
......@@ -164,9 +159,9 @@ let rec dpattern uc { pat_desc = desc; pat_loc = loc } =
Dterm.dpattern ~loc (match desc with
| PPpwild -> DPwild
| PPpvar x -> DPvar (create_user_id x)
| PPpapp (x,pl) ->
| PPpapp (q,pl) ->
let pl = List.map (dpattern uc) pl in
DPapp (find_lsymbol x uc, pl)
DPapp (find_lsymbol uc q, pl)
| PPptuple pl ->
let pl = List.map (dpattern uc) pl in
DPapp (fs_tuple (List.length pl), pl)
......@@ -187,12 +182,12 @@ let quant_var uc (x,ty) =
let chainable_op uc op =
(* non-bool -> non-bool -> bool *)
op.id = "infix =" || op.id = "infix <>" ||
match find_lsymbol (Qident op) uc with
| { ls_args = [ty1;ty2]; ls_value = ty } ->
Opt.fold (fun _ ty -> ty_equal ty ty_bool) true ty
&& not (ty_equal ty1 ty_bool)
&& not (ty_equal ty2 ty_bool)
| _ -> false
match find_lsymbol uc (Qident op) with
| {ls_args = [ty1;ty2]; ls_value = ty} ->
Opt.fold (fun _ ty -> ty_equal ty ty_bool) true ty
&& not (ty_equal ty1 ty_bool)
&& not (ty_equal ty2 ty_bool)
| _ -> false
type global_vs = Ptree.qualid -> vsymbol option
......@@ -201,23 +196,23 @@ let rec dterm uc (gvars: global_vs) denv {pp_desc = desc; pp_loc = loc} =
let highord_app e1 e2 =
DTapp (fs_func_app, [Dterm.dterm ~loc e1; pterm denv e2]) in
let highord_app e1 el = List.fold_left highord_app e1 el in
let qualid_app x el = match gvars x with
let qualid_app q el = match gvars q with
| Some vs ->
highord_app (DTgvar vs) el
| None ->
let ls = find_lsymbol x uc in
let ls = find_lsymbol uc q in
let rec take al l el = match l, el with
| (_::l), (e::el) -> take (pterm denv e :: al) l el
| _, _ -> List.rev al, el in
let al, el = take [] ls.ls_args el in
highord_app (DTapp (ls,al)) el
in
let qualid_app x el = match x with
let qualid_app q el = match q with
| Qident {id = n} ->
(match denv_get_opt denv n with
| Some dt -> highord_app dt el
| None -> qualid_app x el)
| _ -> qualid_app x el
| None -> qualid_app q el)
| _ -> qualid_app q el
in
Dterm.dterm ~loc (match desc with
| PPvar x ->
......@@ -233,10 +228,10 @@ let rec dterm uc (gvars: global_vs) denv {pp_desc = desc; pp_loc = loc} =
| PPinnfix (e12, op2, e3) ->
let make_app de1 op de2 = if op.id = "infix <>" then
let op = { op with id = "infix =" } in
let ls = find_lsymbol (Qident op) uc in
let ls = find_lsymbol uc (Qident op) in
DTnot (Dterm.dterm ~loc (DTapp (ls, [de1;de2])))
else
DTapp (find_lsymbol (Qident op) uc, [de1;de2])
DTapp (find_lsymbol uc (Qident op), [de1;de2])
in
let rec make_chain de1 = function
| [op,de2] ->
......@@ -329,26 +324,14 @@ let rec dterm uc (gvars: global_vs) denv {pp_desc = desc; pp_loc = loc} =
(** Export for program parsing *)
let type_term uc gfn t =
let t = dterm uc gfn denv_empty t in
let type_term uc gvars t =
let t = dterm uc gvars denv_empty t in
Dterm.term ~strict:true ~keep_loc:true t
let type_fmla uc gfn f =
let f = dterm uc gfn denv_empty f in
let type_fmla uc gvars f =
let f = dterm uc gvars denv_empty f in
Dterm.fmla ~strict:true ~keep_loc:true f
let type_term_branch uc gfn p t =
let p = dpattern uc p in
let denv = denv_add_pat denv_empty p in
let t = dterm uc gfn denv t in
Dterm.term_branch ~strict:true ~keep_loc:true p t
let type_fmla_branch uc gfn p f =
let p = dpattern uc p in
let denv = denv_add_pat denv_empty p in
let f = dterm uc gfn denv f in
Dterm.fmla_branch ~strict:true ~keep_loc:true p f
(** Typing declarations *)
let tyl_of_params ~noop uc pl =
......@@ -396,7 +379,7 @@ let add_types dl th =
| Qident x when Mstr.mem x.id def ->
visit x.id
| Qident _ | Qdot _ ->
find_tysymbol q th
find_tysymbol th q
in
Loc.try2 ~loc:(qloc q) ty_app ts (List.map apply tyl)
| PPTtuple tyl ->
......@@ -711,11 +694,11 @@ let add_decl loc th = function
| Ptree.Meta (id, al) ->
let convert = function
| PMAty (PPTtyapp (q,[]))
-> MAts (find_tysymbol q th)
-> MAts (find_tysymbol th q)
| PMAty ty -> MAty (ty_of_pty th ty)
| PMAfs q -> MAls (find_fsymbol q th)
| PMAps q -> MAls (find_psymbol q th)
| PMApr q -> MApr (find_prop q th)
| PMAfs q -> MAls (find_fsymbol th q)
| PMAps q -> MAls (find_psymbol th q)
| PMApr q -> MApr (find_prop th q)
| PMAstr s -> MAstr s
| PMAint i -> MAint i
in
......@@ -729,18 +712,17 @@ let add_decl loc th d =
let type_inst th t s =
let add_inst s = function
| CSns (loc,p,q) ->
let find ns x = find_namespace_ns x ns in
let ns1 = Opt.fold find t.th_export p in
let ns2 = Opt.fold find (get_namespace th) q in
let ns1 = Opt.fold find_namespace_ns t.th_export p in
let ns2 = Opt.fold find_namespace_ns (get_namespace th) q in
Loc.try6 ~loc clone_ns t.th_known t.th_local [] ns2 ns1 s
| CStsym (loc,p,[],PPTtyapp (q,[])) ->
let ts1 = find_tysymbol_ns p t.th_export in
let ts2 = find_tysymbol q th in
let ts1 = find_tysymbol_ns t.th_export p in
let ts2 = find_tysymbol th q in
if Mts.mem ts1 s.inst_ts
then Loc.error ~loc (ClashSymbol ts1.ts_name.id_string);
{ s with inst_ts = Mts.add ts1 ts2 s.inst_ts }
| CStsym (loc,p,tvl,pty) ->
let ts1 = find_tysymbol_ns p t.th_export in
let ts1 = find_tysymbol_ns t.th_export p in
let id = id_user (ts1.ts_name.id_string ^ "_subst") loc in
let tvl = List.map (fun id -> create_user_tv id.id) tvl in
let def = Some (ty_of_pty th pty) in
......@@ -749,24 +731,24 @@ let type_inst th t s =
then Loc.error ~loc (ClashSymbol ts1.ts_name.id_string);
{ s with inst_ts = Mts.add ts1 ts2 s.inst_ts }
| CSfsym (loc,p,q) ->
let ls1 = find_fsymbol_ns p t.th_export in
let ls2 = find_fsymbol q th in
let ls1 = find_fsymbol_ns t.th_export p in
let ls2 = find_fsymbol th q in
if Mls.mem ls1 s.inst_ls
then Loc.error ~loc (ClashSymbol ls1.ls_name.id_string);
{ s with inst_ls = Mls.add ls1 ls2 s.inst_ls }
| CSpsym (loc,p,q) ->
let ls1 = find_psymbol_ns p t.th_export in
let ls2 = find_psymbol q th in
let ls1 = find_psymbol_ns t.th_export p in
let ls2 = find_psymbol th q in
if Mls.mem ls1 s.inst_ls
then Loc.error ~loc (ClashSymbol ls1.ls_name.id_string);
{ s with inst_ls = Mls.add ls1 ls2 s.inst_ls }
| CSlemma (loc,p) ->
let pr = find_prop_ns p t.th_export in
let pr = find_prop_ns t.th_export p in
if Spr.mem pr s.inst_lemma || Spr.mem pr s.inst_goal
then Loc.error ~loc (ClashSymbol pr.pr_name.id_string);
{ s with inst_lemma = Spr.add pr s.inst_lemma }
| CSgoal (loc,p) ->
let pr = find_prop_ns p t.th_export in
let pr = find_prop_ns t.th_export p in
if Spr.mem pr s.inst_lemma || Spr.mem pr s.inst_goal
then Loc.error ~loc (ClashSymbol pr.pr_name.id_string);
{ s with inst_goal = Spr.add pr s.inst_goal }
......
src/parser/typing.mli
View file @ e5ded412
......@@ -42,14 +42,14 @@ val close_file : unit -> theory Mstr.t
val create_user_tv : string -> tvsymbol
val create_user_id : Ptree.ident -> Ident.preid
val qloc : Ptree.qualid -> Loc.position
val string_list_of_qualid : Ptree.qualid -> string list
val print_qualid : Format.formatter -> Ptree.qualid -> unit
val qloc : Ptree.qualid -> Loc.position
exception UnboundSymbol of Ptree.qualid
val find_ns :
('a -> Ident.ident) -> ('b -> string list -> 'a) -> Ptree.qualid -> 'b -> 'a
val find_qualid :
('a -> Ident.ident) -> ('b -> string list -> 'a) -> 'b -> Ptree.qualid -> 'a
type global_vs = Ptree.qualid -> vsymbol option
......@@ -57,10 +57,4 @@ val type_term : theory_uc -> global_vs -> Ptree.lexpr -> term
val type_fmla : theory_uc -> global_vs -> Ptree.lexpr -> term
val type_term_branch :
theory_uc -> global_vs -> Ptree.pattern -> Ptree.lexpr -> pattern * term
val type_fmla_branch :
theory_uc -> global_vs -> Ptree.pattern -> Ptree.lexpr -> pattern * term
val type_inst : theory_uc -> theory -> Ptree.clone_subst list -> th_inst
src/whyml/mlw_dexpr.ml
View file @ e5ded412
......@@ -347,20 +347,21 @@ type 'a later = vsymbol Mstr.t -> 'a
expressions, when the types of locally bound program variables are
already established. *)
type dpre = Loc.position option * term
type dpost = Loc.position option * (pattern * term) list
type dxpost = Loc.position option * (xsymbol * pattern * term) list
type dinvariant = (Loc.position option * term) list
type dspec = {
ds_pre : dpre list;
ds_post : dpost list;
ds_xpost : dxpost list;
type dspec_final = {
ds_pre : term list;
ds_post : (vsymbol option * term) list;
ds_xpost : (vsymbol option * term) list Mexn.t;
ds_reads : vsymbol list;
ds_writes : term list;
ds_variant : variant list;
}
type dspec = ty -> dspec_final
(* Computation specification is also parametrized by the result type.
All vsymbols in the postcondition clauses in the [ds_post] field
must have this type. All vsymbols in the exceptional postcondition
clauses must have the type of the corresponding exception. *)
type dtype_v =
| DSpecV of dity
| DSpecA of dbinder list * dtype_c
......@@ -369,6 +370,8 @@ and dtype_c = dtype_v * dspec later
(** Expressions *)
type dinvariant = term list
type dlazy_op = DEand | DEor
type dexpr = {
......@@ -735,50 +738,33 @@ let to_fmla f = match f.t_ty with
| Some ty when ty_equal ty ty_bool -> t_equ f t_bool_true
| _ -> Loc.error ?loc:f.t_loc Dterm.FmlaExpected
let create_assert (_,f) = t_label_add Split_goal.stop_split (to_fmla f)
let create_assert f = t_label_add Split_goal.stop_split (to_fmla f)
let create_pre fl = t_and_simp_l (List.map create_assert fl)
let create_inv = create_pre
let create_post u (loc,pl) =
let f = match pl with
| [{pat_node = Pwild}, f] -> to_fmla f
| [{pat_node = Pvar v}, f] when vs_equal u v -> to_fmla f
| [{pat_node = Pvar v}, f] -> t_subst_single v (t_var u) (to_fmla f)
| [{pat_node = Papp (fs,[])}, f] when ls_equal fs fs_void -> to_fmla f
| bl -> let mk_b (p,f) = t_close_branch p (to_fmla f) in
let f = t_case (t_var u) (List.map mk_b bl) in
t_label ?loc Slab.empty f in
let f = t_label_add Split_goal.stop_split f in
Mlw_wp.remove_old f
let create_post u (loc,_ as pl) = Loc.try2 ?loc create_post u pl
let create_post ty pll =
let create_post u (v,f) =
let f = match v with
| Some v when vs_equal u v -> f
| Some v -> Loc.try3 ?loc:f.t_loc t_subst_single v (t_var u) f
| None -> f in
let f = Mlw_wp.remove_old (to_fmla f) in
t_label_add Split_goal.stop_split f
let create_post ty ql =
let rec get_var = function
| [] -> create_vsymbol (id_fresh "result") ty
| (_, [{ pat_node = Pvar v }, _]) :: _ -> v
| (Some v, _) :: _ -> Ty.ty_equal_check ty v.vs_ty; v
| _ :: l -> get_var l in
let vs = get_var pll in
let f = t_and_simp_l (List.map (create_post vs) pll) in
Mlw_ty.create_post vs f
let create_xpost pll =
let add_exn (xs,p,f) m = Mexn.change (function
| Some l -> Some ((p,f) :: l)
| None -> Some ((p,f) :: [])) xs m in
let exn_map loc pl =
let m = List.fold_right add_exn pl Mexn.empty in
Mexn.map (fun pl -> [loc, pl]) m in
let add_map (loc,pl) m =
Mexn.union (fun _ l r -> Some (l @ r)) (exn_map loc pl) m in
let m = List.fold_right add_map pll Mexn.empty in
Mexn.mapi (fun xs pll -> create_post (ty_of_ity xs.xs_ity) pll) m
let create_post vty pll = create_post (ty_of_vty vty) pll
let spec_of_dspec eff vty dsp = {
let u = get_var ql in
let f = t_and_simp_l (List.map (create_post u) ql) in
Mlw_ty.create_post u f
let create_xpost xql =
Mexn.mapi (fun xs ql -> create_post (ty_of_ity xs.xs_ity) ql) xql
let spec_of_dspec eff ty dsp = {
c_pre = create_pre dsp.ds_pre;
c_post = create_post vty dsp.ds_post;
c_post = create_post ty dsp.ds_post;
c_xpost = create_xpost dsp.ds_xpost;
c_effect = eff;
c_variant = dsp.ds_variant;
......@@ -817,9 +803,8 @@ let rec effect_of_term t = match t.t_node with
Loc.errorm ?loc:t.t_loc "unsupported effect expression"
let effect_of_dspec dsp =
let add_raise eff (xs,_,_) = eff_raise eff xs in
let add_raise eff (_,pl) = List.fold_left add_raise eff pl in
let eff = List.fold_left add_raise eff_empty dsp.ds_xpost in
let add_raise xs _ eff = eff_raise eff xs in
let eff = Mexn.fold add_raise dsp.ds_xpost eff_empty in
let svs = List.fold_right Svs.add dsp.ds_reads Svs.empty in
let add_write (svs,mreg,eff) t =
let vs, fd = effect_of_term t in
......@@ -968,8 +953,9 @@ let add_binders env pvl = List.fold_left add_pvsymbol env pvl
(** Abstract values *)
let rec type_c env pvs vars otv (dtyv, dsp) =
let dsp = dsp env.vsm in
let vty = type_v env pvs vars otv dtyv in
let res = ty_of_vty vty in
let dsp = dsp env.vsm res in
let esvs, _, eff = effect_of_dspec dsp in
(* refresh every subregion of a modified region *)
let writes = Sreg.union eff.eff_writes eff.eff_ghostw in
......@@ -979,7 +965,7 @@ let rec type_c env pvs vars otv (dtyv, dsp) =
(* eff_compare every type variable not marked as opaque *)
let eff = Stv.fold_left eff_compare eff (Stv.diff vars.vars_tv otv) in
(* make spec *)
let spec = spec_of_dspec eff vty dsp in
let spec = spec_of_dspec eff res dsp in
if spec.c_variant <> [] then Loc.errorm
"variants are not allowed in a parameter declaration";
(* we add a fake variant term for every external variable in effect
......@@ -1177,13 +1163,14 @@ and try_expr keep_loc uloc env (argl,res) node =
| DEabsurd ->
e_absurd (ity_of_dity res)
| DEassert (ak,f) ->
e_assert ak (create_assert (None, f env.vsm))
e_assert ak (create_assert (f env.vsm))
| DEabstract (de,dsp) ->
let e = get env de in
let dsp = dsp env.vsm in
let tyv = ty_of_vty e.e_vty in
let dsp = dsp env.vsm tyv in
if dsp.ds_variant <> [] then Loc.errorm
"variants are not allowed in `abstract'";
let spec = spec_of_dspec e.e_effect e.e_vty dsp in
let spec = spec_of_dspec e.e_effect tyv dsp in
check_user_effect e spec false dsp;
e_abstract e spec
| DEmark (id,de) ->
......@@ -1266,8 +1253,9 @@ and expr_lam ~keep_loc uloc env gh pvl de dsp =
let e = e_ghostify gh (expr ~keep_loc uloc env de) in
if not gh && e.e_ghost then (* TODO: localize better *)
Loc.errorm ?loc:de.de_loc "ghost body in a non-ghost function";
let dsp = dsp env.vsm in
let spec = spec_of_dspec e.e_effect e.e_vty dsp in
let tyv = ty_of_vty e.e_vty in
let dsp = dsp env.vsm tyv in
let spec = spec_of_dspec e.e_effect tyv dsp in
{ l_args = pvl; l_expr = e; l_spec = spec }, dsp
let val_decl ~keep_loc:_ vald =
......
src/whyml/mlw_dexpr.mli
View file @ e5ded412
......@@ -48,7 +48,7 @@ type dpattern_node =
| DPor of dpattern * dpattern
| DPas of dpattern * preid
(** Specifications *)
(** Binders *)
type ghost = bool
......@@ -56,25 +56,28 @@ type opaque = Stv.t
type dbinder = preid option * ghost * opaque * dity
(** Specifications *)
type 'a later = vsymbol Mstr.t -> 'a
(* specification terms are parsed and typechecked after the program
(* Specification terms are parsed and typechecked after the program
expressions, when the types of locally bound program variables are
already established. *)
type dpre = Loc.position option * term
type dpost = Loc.position option * (pattern * term) list
type dxpost = Loc.position option * (xsymbol * pattern * term) list
type dinvariant = (Loc.position option * term) list
type dspec = {
ds_pre : dpre list;
ds_post : dpost list;
ds_xpost : dxpost list;
type dspec_final = {
ds_pre : term list;
ds_post : (vsymbol option * term) list;
ds_xpost : (vsymbol option * term) list Mexn.t;
ds_reads : vsymbol list;
ds_writes : term list;
ds_variant : variant list;
}
type dspec = ty -> dspec_final
(* Computation specification is also parametrized by the result type.