Commit afa16279 authored by Andrei Paskevich's avatar Andrei Paskevich

whyml: introduce rich specification types, rework e_any

parent ccdb4088
......@@ -393,8 +393,8 @@ install_local: bin/why3
# Whyml (new API)
########
MLW_FILES = mlw_ty mlw_expr mlw_decl mlw_module mlw_pretty \
mlw_wp mlw_dtree mlw_dty mlw_typing mlw_main
MLW_FILES = mlw_ty mlw_expr mlw_wp mlw_decl mlw_module \
mlw_pretty mlw_dtree mlw_dty mlw_typing mlw_main
MLWMODULES = $(addprefix src/whyml/, $(MLW_FILES))
......
......@@ -38,13 +38,6 @@ type ghost = bool
type dpre = Ptree.pre
type dpost = Ptree.pre
type dxpost = (xsymbol * dpost) list
type deffect = {
deff_reads : Ptree.lexpr list;
deff_writes : Ptree.lexpr list;
deff_raises : xsymbol list;
}
type dbinder = ident * ghost * dity
(**
......@@ -82,7 +75,6 @@ and dexpr_desc =
| DElet of ident * dexpr * dexpr
| DEletrec of drecfun list * dexpr
| DEassign of dexpr * dexpr
| DEsequence of dexpr * dexpr
| DEif of dexpr * dexpr * dexpr
| DEloop of dvariant list * dinvariant * dexpr
| DElazy of Ptree.lazy_op * dexpr * dexpr
......@@ -94,8 +86,19 @@ and dexpr_desc =
| DEfor of ident * dexpr * Ptree.for_direction * dexpr * dinvariant * dexpr
| DEassert of Ptree.assertion_kind * Ptree.lexpr
| DEmark of ident * dexpr
(* | DEany of dutype_c *)
| DEghost of dexpr
(*
| DEany of deffect
*)
and drecfun = ident * dity * dlambda
and dlambda = dbinder list * dvariant list * dpre * dexpr * dpost * dxpost
(*
and deffect = {
deff_reads : dexpr list;
deff_writes : dexpr list;
deff_raises : (ghost * xsymbol) list;
}
*)
This diff is collapsed.
......@@ -83,6 +83,39 @@ val create_plsymbol : preid -> vty_value list -> vty_value -> plsymbol
(* FIXME? Effect calculation is hardwired to correspond to constructors
and projections: mutable arguments are reset, mutable result is read. *)
(** specification *)
type pre = term (* precondition *)
type post (* postcondition: a formula with a bound variable *)
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 =
| LetV of pvsymbol
| LetA of psymbol
type val_decl = private {
val_name : let_var;
val_decl : type_v;
val_vars : varset Mid.t;
}
val create_val_decl : Ident.preid -> type_v -> val_decl
(** patterns *)
type ppattern = private {
......@@ -112,18 +145,6 @@ val make_ppattern : pre_ppattern -> vty_value -> pvsymbol Mstr.t * ppattern
type assertion_kind = Aassert | Aassume | Acheck
type pre = term (* precondition *)
type post (* postcondition: a formula with a bound variable *)
type xpost = post Mexn.t (* exceptional postconditions *)
val create_post : vsymbol -> term -> post
val open_post : post -> vsymbol * term
type variant = {
v_term : term; (* : tau *)
v_rel : lsymbol option; (* tau tau : prop *)
}
type expr = private {
e_node : expr_node;
e_vty : vty;
......@@ -144,7 +165,7 @@ and expr_node = private
| Ecase of expr * (ppattern * expr) list
| Eassign of expr * region * pvsymbol
| Eghost of expr
| Eany of any_effect
| Eany of type_c
| Eraise of xsymbol * expr
| Etry of expr * (xsymbol * pvsymbol * expr) list
| Eassert of assertion_kind * term
......@@ -155,10 +176,6 @@ and let_defn = private {
let_expr : expr;
}
and let_var =
| LetV of pvsymbol
| LetA of psymbol
and rec_defn = private {
rec_ps : psymbol;
rec_lambda : lambda;
......@@ -174,13 +191,9 @@ and lambda = {
l_xpost : xpost;
}
(* TODO? Every top region in the type of Eany is reset.
This is enough for our current purposes, but we might
need to be more flexible later. *)
and any_effect = {
aeff_reads : expr list; (* for a ghost read, use a ghost expression *)
aeff_writes : expr list; (* for a ghost write, use a ghost expression *)
aeff_raises : (bool * xsymbol) list; (* ghost raise * exception symbol *)
and variant = {
v_term : term; (* : tau *)
v_rel : lsymbol option; (* tau tau : prop *)
}
val e_label : ?loc:Loc.position -> Slab.t -> expr -> expr
......@@ -222,7 +235,7 @@ exception Immutable of expr
val e_assign : expr -> expr -> expr
val e_ghost : expr -> expr
val e_any : any_effect -> ity -> expr
val e_any : type_c -> expr
val e_void : expr
......@@ -239,4 +252,3 @@ val e_try : expr -> (xsymbol * pvsymbol * expr) list -> expr
val e_absurd : ity -> expr
val e_assert : assertion_kind -> term -> expr
......@@ -131,6 +131,10 @@ let create_varset tvs regs = {
vars_reg = regs;
}
let rec reg_occurs r vars =
let check r r' = reg_equal r r' || reg_occurs r r'.reg_ity.ity_vars in
Sreg.exists (check r) vars.vars_reg
(* value type symbols *)
module Itsym = WeakStructMake (struct
......@@ -601,12 +605,7 @@ let eff_full_inst s e =
}
let eff_filter vars e =
let rec check r vars =
Sreg.exists (occurs r) vars.vars_reg
and occurs r r' =
reg_equal r r' || check r r'.reg_ity.ity_vars
in
let check r = check r vars in
let check r = reg_occurs r vars in
let reset r = function
| _ when not (check r) -> None
| Some u as v when check u -> Some v
......@@ -665,6 +664,10 @@ let vty_value ?(ghost=false) ?mut ity =
vtv_vars = vars;
}
let vtv_unmut vtv =
if vtv.vtv_mut = None then vtv else
vty_value ~ghost:vtv.vtv_ghost vtv.vtv_ity
let vty_arrow vtv ?(effect=eff_empty) ?(ghost=false) vty =
(* mutable arguments are rejected outright *)
if vtv.vtv_mut <> None then
......@@ -672,10 +675,8 @@ let vty_arrow vtv ?(effect=eff_empty) ?(ghost=false) vty =
(* we accept a mutable vty_value as a result to simplify Mlw_expr,
but erase it in the signature: only projections return mutables *)
let vty = match vty with
| VTvalue ({ vtv_mut = Some r ; vtv_vars = vars } as vtv) ->
let vars = { vars with vars_reg = Sreg.remove r vars.vars_reg } in
VTvalue { vtv with vtv_mut = None ; vtv_vars = vars }
| _ -> vty
| VTvalue v -> VTvalue (vtv_unmut v)
| VTarrow _ -> vty
in {
vta_arg = vtv;
vta_result = vty;
......@@ -722,16 +723,16 @@ and vty_full_inst s = function
| VTvalue vtv -> VTvalue (vtv_full_inst s vtv)
| VTarrow vta -> VTarrow (vta_full_inst s vta)
let vta_filter vars vta =
let vars = vars_union vars vta.vta_vars in
let rec filter a =
let vty = match a.vta_result with
| VTarrow a -> VTarrow (filter a)
| v -> v in
let effect = eff_filter vars a.vta_effect in
vty_arrow ~ghost:a.vta_ghost ~effect a.vta_arg vty
in
filter vta
let rec vta_filter vars a =
let vars = vars_union vars a.vta_arg.vtv_vars in
let vty, vars = match a.vta_result with
(* FIXME? We allow effects on the regions from a VTvalue result,
but only reset is actually meaningful. Should we require that
any new region in the result be reset? *)
| VTvalue v -> a.vta_result, vars_union vars v.vtv_vars
| VTarrow a -> VTarrow (vta_filter vars a), vars in
let effect = eff_filter vars a.vta_effect in
vty_arrow ~ghost:a.vta_ghost ~effect a.vta_arg vty
(** THE FOLLOWING CODE MIGHT BE USEFUL LATER FOR WPgen *)
(*
......
......@@ -86,6 +86,8 @@ val ity_hash : ity -> int
val reg_equal : region -> region -> bool
val reg_hash : region -> int
val reg_occurs : region -> varset -> bool
exception BadItyArity of itysymbol * int * int
exception BadRegArity of itysymbol * int * int
exception DuplicateRegion of region
......@@ -255,6 +257,8 @@ val vty_vars : varset -> vty -> varset
val vty_ghost : vty -> bool
val vty_ghostify : vty -> vty
val vtv_unmut : vty_value -> vty_value
(* the substitution must cover not only vta.vta_tvs and vta.vta_regs
but also every type variable and every region in vta_effect *)
val vta_full_inst : ity_subst -> vty_arrow -> vty_arrow
......
......@@ -211,12 +211,17 @@ let mk_var e =
dexpr_loc = e.dexpr_loc;
dexpr_lab = [] }
let mk_id s loc =
{ id = s; id_loc = loc; id_lab = [] }
let mk_dexpr desc dity loc labs =
{ dexpr_desc = desc; dexpr_type = dity; dexpr_loc = loc; dexpr_lab = labs }
let mk_let ~loc ~uloc e (desc,dity) =
if test_var e then desc, dity else
let loc = def_option loc uloc in
let e1 = {
dexpr_desc = desc; dexpr_type = dity; dexpr_loc = loc; dexpr_lab = [] } in
DElet ({ id = "q"; id_lab = []; id_loc = loc }, e, e1), dity
let e1 = mk_dexpr desc dity loc [] in
DElet (mk_id "q" loc, e, e1), dity
(* patterns *)
......@@ -257,9 +262,6 @@ let find_variant_ls ~loc uc p =
with Not_found ->
errorm ~loc "unbound symbol %a" Typing.print_qualid p
let mk_dexpr desc dity loc labs =
{ dexpr_desc = desc; dexpr_type = dity; dexpr_loc = loc; dexpr_lab = labs }
let rec dpattern denv ({ pat_loc = loc } as pp) = match pp.pat_desc with
| Ptree.PPpwild ->
PPwild, create_type_variable (), denv
......@@ -309,6 +311,16 @@ and dpat_app denv ({ dexpr_loc = loc } as de) ppl =
Loc.try2 loc unify de.dexpr_type (make_arrow_type tyl res);
pp, res, denv
(*
let deff_of_peff ~loc denv pe =
{ deff_reads = pe.pe_reads;
deff_writes = pe.pe_writes;
deff_raises =
List.map (fun q -> false, find_xsymbol ~loc denv.uc q) pe.pe_raises; }
*)
let dexpr_unit ~loc = hidden_ls ~loc (fs_tuple 0)
let dexpr_app e el =
let res = create_type_variable () in
let tyl = List.map (fun a -> a.dexpr_type) el in
......@@ -365,7 +377,7 @@ and dexpr_desc denv loc = function
let e1 = dexpr denv e1 in
expected_type e1 dity_unit;
let e2 = dexpr denv e2 in
DElet ({ id = "_"; id_lab = []; id_loc = loc }, e1, e2), e2.dexpr_type
DElet (mk_id "_" loc, e1, e2), e2.dexpr_type
| Ptree.Eif (e1, e2, e3) ->
let e1 = dexpr denv e1 in
expected_type e1 dity_bool;
......@@ -454,7 +466,7 @@ and dexpr_desc denv loc = function
let dity = specialize_xsymbol xs in
let e1 = match e1 with
| Some e1 -> dexpr denv e1
| None when ity_equal xs.xs_ity ity_unit -> hidden_ls ~loc (fs_tuple 0)
| None when ity_equal xs.xs_ity ity_unit -> dexpr_unit ~loc
| _ -> errorm ~loc "exception argument expected" in
expected_type e1 dity;
DEraise (xs, e1), res
......@@ -465,7 +477,7 @@ and dexpr_desc denv loc = function
let dity = specialize_xsymbol xs in
let id, denv = match id with
| Some id -> id, add_var id dity denv
| None -> { id = "void" ; id_loc = loc ; id_lab = [] }, denv in
| None -> mk_id "void" loc, denv in
xs, id, dexpr denv e
in
let cl = List.map branch cl in
......@@ -477,12 +489,35 @@ and dexpr_desc denv loc = function
| Ptree.Emark (id, e1) ->
let e1 = dexpr denv e1 in
DEmark (id, e1), e1.dexpr_type
| Ptree.Eany _ ->
errorm ~loc "\"any\" expressions are not supported"
(*
| Ptree.Eany { pc_result_type = Tpure pty;
pc_effect = pe;
pc_pre = { pp_desc = PPtrue };
pc_post = { pp_desc = PPtrue },[]; } ->
let dity = dity_of_pty ~user:true denv pty in
DEany (deff_of_peff pe), dity
| Ptree.Eany { pc_result_type = Tarrow (bl,tyc);
pc_effect = pe;
pc_pre = { pp_desc = PPtrue };
pc_post = { pp_desc = PPtrue },[]; } ->
let e1 = mk_dexpr (DEany (deff_of_peff pe)) dity_unit loc [] in
let e2 = { pp_desc = Ptree.Eany tyc; pp_loc = loc } in
let d2 = Ptree.Efun (bl,(tyc.pc_pre,e2,tyc.pc_post)) in
let e2 = dexpr denv { pp_desc = d2; pp_loc = loc } in
DElet (mk_id "_" loc, e1, e2), e2.dexpr_type
| Ptree.Eany tyc ->
let bl = [mk_id "_" loc, None] in
let e = dtype_v tyc.pc_effect tyc.pc_result_type in
let lam,dity = dlambda ~loc denv bl None (tyc.pc_pre, e, tyc.pc_post) in
let fn = mk_dexpr (DEfun lam) dity loc [] in
dexpr_app fn [dexpr_unit ~loc]
*)
| Ptree.Eloop (_ann, _e1) ->
assert false (*TODO*)
| Ptree.Efor (_id, _e1, _dir, _e2, _lexpr_opt, _e3) ->
assert false (*TODO*)
| Ptree.Eany (_type_c) ->
assert false (*TODO*)
| Ptree.Eabstract (_e1, _post) ->
assert false (*TODO*)
......@@ -520,6 +555,20 @@ and dlambda ~loc denv bl var (p, e, (q, xq)) =
(fun (q,f) -> find_xsymbol ~loc:f.pp_loc denv.uc q, f) xq in
(bl, var, p, e, q, xq), make_arrow_type tyl e.dexpr_type
(*
and dtype_v ~loc denv = function
| Ptree.Tpure pty ->
let dity = dity_of_pty ~user:true denv pty in
let deff = { deff_reads = []; deff_writes = []; deff_raises = [] } in
DEany deff, dity
| Ptree.Tarrow (bl, tyc) ->
let pptrue = { pp_desc = PPtrue ; pp_loc = loc } in
let d = Ptree.Eany { tyc with pc_pre = pptrue; pc_post = pptrue,[] } in
let tr = tyc.pc_pre, { expr_desc = d; expr_loc = loc }, tyc.pc_post in
let lam, dity = dlambda ~loc denv bl None tr in
DEfun lam, dity
*)
type lenv = {
mod_uc : module_uc;
let_vars : let_var Mstr.t;
......@@ -577,7 +626,7 @@ let rec expr lenv de = match de.dexpr_desc with
let e2 = expr lenv de2 in
e_rec [def] e2
| DEfun lam ->
let x = { id = "fn"; id_loc = de.dexpr_loc; id_lab = [] } in
let x = mk_id "fn" de.dexpr_loc in
let def = expr_fun lenv x lam in
let e2 = e_cast def.rec_ps (VTarrow def.rec_ps.ps_vta) in
e_rec [def] e2
......@@ -651,6 +700,16 @@ let rec expr lenv de = match de.dexpr_desc with
let ld = create_let_defn (Denv.create_user_id x) e_setmark in
let lenv = add_local x.id ld.let_var lenv in
e_let ld (expr lenv de1)
(*
| DEany deff ->
let aeff = {
aeff_reads = List.map (expr lenv) deff.deff_reads;
aeff_writes = List.map (expr lenv) deff.deff_writes;
aeff_raises = deff.deff_raises } in
e_any aeff (ity_of_dity de.dexpr_type)
*)
| DEghost de1 ->
e_ghost (expr lenv de1)
| _ ->
assert false (*TODO*)
......
......@@ -19,6 +19,9 @@
(**************************************************************************)
open Why3
open Mlw_ty
open Mlw_ty.T
open Mlw_expr
(** WP-only builtins *)
......@@ -31,4 +34,4 @@ val fs_at : Term.lsymbol
val th_mark : Theory.theory
val fs_setmark : Term.lsymbol
val e_setmark : Mlw_expr.expr
val e_setmark : expr
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