Commit 46bac1d0 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

Expr: forbid PKls, store the mfield pv inside psymbols

Dexpr: more stuff
parent 0a24262b
......@@ -381,7 +381,7 @@ and dexpr_node =
| DElazy of lazy_op * dexpr * dexpr
| DEif of dexpr * dexpr * dexpr
| DEcase of dexpr * (dpattern * dexpr) list
| DEassign of (dexpr * pvsymbol * dexpr) list
| DEassign of (dexpr * psymbol * dexpr) list
| DEwhile of dexpr * (dinvariant * variant list) later * dexpr
| DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr
| DEtry of dexpr * (xsymbol * dpattern * dexpr) list
......@@ -608,11 +608,6 @@ let dpattern ?loc node =
in
Loc.try1 ?loc dpat node
let _ = ity_of_dity, reunify_regions, dvty_int, dvty_real,
dvty_bool, dvty_unit, print_ity, print_reg, print_dity,
specialize_pv, specialize_xs, dvty_of_dtype_v, dexpr_expected_type
(*
let dexpr ?loc node =
let get_dvty = function
| DEvar (_,dvty) ->
......@@ -621,112 +616,104 @@ let dexpr ?loc node =
[], specialize_pv pv
| DEgpsym ps ->
specialize_ps ps
| DEplapp (pl,del) ->
let argl, res = specialize_pl pl in
dity_unify_app pl.pl_ls dexpr_expected_type del argl;
[], res
| DElsapp (ls,del) ->
let argl, res = specialize_ls ls in
dity_unify_app ls dexpr_expected_type del argl;
[], res
| DEapply ({de_dvty = (dity::argl, res)}, de2) ->
dexpr_expected_type de2 dity;
argl, res
| DEapply ({de_dvty = ([],res)} as de1, de2) ->
let rec not_arrow = function
| Dvar {contents = Dval dity} -> not_arrow dity
| Dpur (ts,_) -> not (ts_equal ts Ty.ts_func)
| Dvar _ -> false | _ -> true in
if not_arrow res then Loc.errorm ?loc:de1.de_loc
"This expression has type %a,@ it cannot be applied" print_dity res;
let argl, res = specialize_ls fs_func_app in
dity_unify_app fs_func_app dexpr_expected_type [de1;de2] argl;
[], res
| DEconst (Number.ConstInt _) ->
dvty_int
| DEconst (Number.ConstReal _) ->
dvty_real
| DEfun ((_,_,[],_,_),_) ->
invalid_arg "Dexpr.dexpr: empty argument list in DEfun"
| DEapp (de0,del0) ->
let argl0, res0 = de0.de_dvty in
let rec dig res del = match del with
| de::del ->
let f,a,r = match specialize_ps ps_func_app with
| [f;a],r -> f,a,r | _ -> assert false in
begin try dity_unify res f with Exit ->
if argl0 = [] && res == res0 then Loc.errorm ?loc:de0.de_loc
"This expression has type %a,@ it cannot be applied"
print_dity (dity_of_dvty de0.de_dvty)
else Loc.errorm ?loc:de0.de_loc
"This expression has type %a,@ but is applied to %d arguments"
print_dity (dity_of_dvty de0.de_dvty) (List.length del0) end;
dexpr_expected_type de a;
dig r del
| [] -> res in
let rec down argl del = match argl, del with
| arg::argl, de::del -> dexpr_expected_type de arg; down argl del
| _, [] -> argl, res0
| [], _ -> argl, dig res0 del in
down argl0 del0
| DEfun (bl,_,de) ->
List.map (fun (_,_,t) -> t) bl, dity_of_dvty de.de_dvty
| DElet (_,de)
| DEfun (_,de)
| DErec (_,de) ->
de.de_dvty
| DElam ([],_,_) ->
invalid_arg "Dexpr.dexpr: empty argument list in DElam"
| DElam (bl,{de_dvty = (argl,res)},_) ->
List.fold_right (fun (_,_,_,t) l -> t::l) bl argl, res
| DEnot de ->
dexpr_expected_type de dity_bool;
de.de_dvty
| DElazy (_,de1,de2) ->
dexpr_expected_type de1 dity_bool;
dexpr_expected_type de2 dity_bool;
de1.de_dvty
| DEif (de1,de2,de3) ->
let res = dity_fresh () in
dexpr_expected_type de1 dity_bool;
dexpr_expected_type de2 res;
dexpr_expected_type de3 res;
de2.de_dvty
[], res
| DEcase (_,[]) ->
invalid_arg "Dexpr.dexpr: empty branch list in DEcase"
| DEcase (de,bl) ->
let ety = dity_fresh () in
let res = dity_fresh () in
dexpr_expected_type de ety;
let branch (dp,de) =
List.iter (fun (dp,de) ->
dpat_expected_type dp ety;
dexpr_expected_type de res in
List.iter branch bl;
dexpr_expected_type de res) bl;
[], res
| DEassign (pl,de1,de2) ->
let argl, res = specialize_pl pl in
dity_unify_app pl.pl_ls dexpr_expected_type [de1] argl;
dexpr_expected_type_weak de2 res;
| DEassign al ->
List.iter (fun (de1,ps,de2) ->
let argl, res = specialize_ps ps in
let ls = match ps.ps_logic with PLls ls -> ls
| _ -> invalid_arg "Dexpr.dexpr: not a field" in
dity_unify_app ls dexpr_expected_type [de1] argl;
dexpr_expected_type_weak de2 res) al;
dvty_unit
| DElazy (_,de1,de2) ->
| DEwhile (de1,_,de2) ->
dexpr_expected_type de1 dity_bool;
dexpr_expected_type de2 dity_bool;
de1.de_dvty
| DEnot de ->
dexpr_expected_type de dity_bool;
dexpr_expected_type de2 dity_unit;
de2.de_dvty
| DEfor (_,de_from,_,de_to,_,de) ->
dexpr_expected_type de_from dity_int;
dexpr_expected_type de_to dity_int;
dexpr_expected_type de dity_unit;
de.de_dvty
| DEtrue
| DEfalse ->
dvty_bool
| DEraise (xs,de) ->
dexpr_expected_type de (specialize_xs xs);
[], dity_fresh ()
| DEtry (_,[]) ->
invalid_arg "Dexpr.dexpr: empty branch list in DEtry"
| DEtry (de,bl) ->
let res = dity_fresh () in
dexpr_expected_type de res;
let branch (xs,dp,de) =
let ety = specialize_xs xs in
dpat_expected_type dp ety;
dexpr_expected_type de res in
List.iter branch bl;
de.de_dvty
| DEfor (_,de_from,_,de_to,_,de) ->
dexpr_expected_type de_from dity_int;
dexpr_expected_type de_to dity_int;
dexpr_expected_type de dity_unit;
de.de_dvty
| DEwhile (de1,_,de2) ->
dexpr_expected_type de1 dity_bool;
dexpr_expected_type de2 dity_unit;
de2.de_dvty
| DEloop (_,de) ->
dexpr_expected_type de dity_unit;
de.de_dvty
| DEabsurd ->
List.iter (fun (xs,dp,de) ->
dpat_expected_type dp (specialize_xs xs);
dexpr_expected_type de res) bl;
[], res
| DEraise (xs,de) ->
dexpr_expected_type de (specialize_xs xs);
[], dity_fresh ()
| DEassert _ ->
dvty_unit
| DEabstract (de,_)
| DEmark (_,de)
| DEghost de ->
de.de_dvty
| DEany (dtv,_) ->
| DEassert _ ->
dvty_unit
| DEpure _
| DEabsurd ->
[], dity_fresh ()
| DEtrue
| DEfalse ->
dvty_bool
| DEany dtv ->
dvty_of_dtype_v dtv
| DEcast (de,ity) ->
dexpr_expected_type_weak de (dity_of_ity ity);
de.de_dvty
| DEmark (_,de)
| DEuloc (de,_)
| DElabel (de,_) ->
de.de_dvty in
......@@ -735,9 +722,9 @@ let dexpr ?loc node =
let mk_dexpr loc d n = { de_node = n; de_dvty = d; de_loc = loc }
let de_void loc = mk_dexpr loc dvty_unit (DElsapp (fs_void, []))
let de_void loc = mk_dexpr loc dvty_unit (DEgpsym ps_void)
let pat_void loc = { dp_pat = PPlapp (fs_void, []);
let pat_void loc = { dp_pat = PPapp (ps_void, []);
dp_dity = dity_unit; dp_vars = Mstr.empty; dp_loc = loc }
(** Final stage *)
......@@ -746,7 +733,7 @@ let pat_void loc = { dp_pat = PPlapp (fs_void, []);
let binders bl =
let sn = ref Sstr.empty in
let binder (id, ghost, _, dity) =
let binder (id, ghost, dity) =
let id = match id with
| Some ({pre_name = n} as id) ->
let exn = match id.pre_loc with
......@@ -757,9 +744,6 @@ let binders bl =
create_pvsymbol id ~ghost (ity_of_dity dity) in
List.map binder bl
let opaque_binders otv bl =
List.fold_left (fun otv (_,_,s,_) -> Stv.union otv s) otv bl
(** Specifications *)
let to_fmla f = match f.t_ty with
......@@ -767,67 +751,45 @@ 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_pre fl = t_and_simp_l (List.map create_assert fl)
let create_inv = create_pre
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
| (Some v, _) :: _ -> Ty.ty_equal_check ty v.vs_ty; v
| _ :: l -> get_var l in
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_assert = to_fmla
let create_invariant pl = List.map to_fmla pl
let create_pre = create_invariant
let create_post ty ql = List.map (fun (v,f) ->
let f = (*Mlw_wp.remove_old*) (to_fmla f) in match v with
| None -> Ity.create_post (create_vsymbol (id_fresh "result") ty) f
| Some v -> Ty.ty_equal_check ty v.vs_ty; Ity.create_post v f) ql
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 ty dsp.ds_post;
c_xpost = create_xpost dsp.ds_xpost;
c_effect = eff;
c_variant = dsp.ds_variant;
c_letrec = 0;
}
(*
(** User effects *)
let mk_field ity gh mut = {fd_ity = ity; fd_ghost = gh; fd_mut = mut}
let rec effect_of_term t = match t.t_node with
| Tvar vs ->
let pv = try restore_pv vs with Not_found ->
Loc.errorm ?loc:t.t_loc "unsupported effect expression" in
vs, mk_field pv.pv_ity pv.pv_ghost None
vs, pv.pv_ity, None
| Tapp (fs,[ta]) ->
let vs, fa = effect_of_term ta in
let ofa,ofv = try match restore_pl fs with
| {pl_args = [ofa]; pl_value = ofv} ->
ofa, ofv
let vs,ity,fa = effect_of_term ta in
let ofa,ofv = try match restore_ps fs with
| {ps_cty = {cty_args = [ofa]; cty_result = ofv}} -> ofa, ofv
| _ -> assert false
with Not_found -> match fs with
| {ls_args = [tya]; ls_value = Some tyv} ->
mk_field (ity_of_ty tya) false None,
mk_field (ity_of_ty tyv) false None
mk_field (ity_of_ty tya) None,
mk_field (ity_of_ty tyv) None
| {ls_args = [_]; ls_value = None} ->
Loc.errorm ?loc:t.t_loc "unsupported effect expression"
| _ -> assert false in
let sbs = ity_match ity_subst_empty ofa.fd_ity fa.fd_ity in
let ity = try ity_full_inst sbs ofv.fd_ity with Not_found ->
Loc.errorm ?loc:t.t_loc "unsupported effect expression" in
let gh = (fa.fd_ghost && not ofa.fd_ghost) || ofv.fd_ghost in
let mut = Opt.map (reg_full_inst sbs) ofv.fd_mut in
vs, mk_field ity gh mut
vs, mk_field ity mut
| _ ->
Loc.errorm ?loc:t.t_loc "unsupported effect expression"
......@@ -841,13 +803,11 @@ let effect_of_dspec dsp =
match fd.fd_mut, fd.fd_ity.ity_node with
| Some reg, _ ->
Svs.add vs svs, Mreg.add reg t mreg,
eff_write eff ~ghost:fd.fd_ghost reg
| None, Ityapp ({its_ghrl = ghrl},_,(_::_ as regl)) ->
eff_write eff reg
| None, Ityapp (_,_,(_::_ as regl)) ->
let add_reg mreg reg = Mreg.add reg t mreg in
let add_write eff gh reg =
eff_write eff ~ghost:(fd.fd_ghost || gh) reg in
Svs.add vs svs, List.fold_left add_reg mreg regl,
List.fold_left2 add_write eff ghrl regl
List.fold_left eff_write eff regl
| _ ->
Loc.errorm ?loc:t.t_loc "mutable expression expected"
in
......@@ -1075,6 +1035,7 @@ let rec type_c env pvs vars otv (dtyv, dsp) =
let res = ty_of_vty vty in
let dsp = dsp env.vsm res in
let esvs, _, eff = effect_of_dspec dsp in
let eff = refresh_of_effect eff in
(* refresh every subregion of a modified region *)
let writes = Sreg.union eff.eff_writes eff.eff_ghostw in
let check u eff =
......@@ -1274,7 +1235,7 @@ and try_expr keep_loc uloc env ({de_dvty = argl,res} as de0) =
let env = add_pvsymbol env pv in
let e = get env de in
let inv = dinv env.vsm in
e_for pv e_from dir e_to (create_inv inv) e
e_for pv e_from dir e_to (create_invariant inv) e
| DEwhile (de1,varl_inv,de2) ->
let loc = de0.de_loc in
let de3 = mk_dexpr loc dvty_unit
......@@ -1287,7 +1248,7 @@ and try_expr keep_loc uloc env ({de_dvty = argl,res} as de0) =
| DEloop (varl_inv,de) ->
let e = get env de in
let varl, inv = varl_inv env.vsm in
e_loop (create_inv inv) varl e
e_loop (create_invariant inv) varl e
| DEabsurd ->
e_absurd (ity_of_dity res)
| DEassert (ak,f) ->
......
......@@ -105,7 +105,7 @@ and dexpr_node =
| DElazy of lazy_op * dexpr * dexpr
| DEif of dexpr * dexpr * dexpr
| DEcase of dexpr * (dpattern * dexpr) list
| DEassign of (dexpr * pvsymbol * dexpr) list
| DEassign of (dexpr * psymbol * dexpr) list
| DEwhile of dexpr * (dinvariant * variant list) later * dexpr
| DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr
| DEtry of dexpr * (xsymbol * dpattern * dexpr) list
......@@ -153,9 +153,7 @@ val denv_get_opt : denv -> string -> dexpr_node option
val dpattern : ?loc:Loc.position -> dpattern_node -> dpattern
(*
val dexpr : ?loc:Loc.position -> dexpr_node -> dexpr
*)
type pre_fun_defn = preid * ghost * ps_kind *
dbinder list * dity * (denv -> (dspec * variant list) later * dexpr)
......
......@@ -18,10 +18,11 @@ open Ity
(** {2 Program symbols} *)
type psymbol = {
ps_name : ident;
ps_cty : cty;
ps_ghost : bool;
ps_logic : ps_logic;
ps_name : ident;
ps_cty : cty;
ps_ghost : bool;
ps_logic : ps_logic;
ps_mfield : pvsymbol option;
}
and ps_logic =
......@@ -46,12 +47,13 @@ let ps_compare ps1 ps2 = id_compare ps1.ps_name ps2.ps_name
let mk_ps, restore_ps =
let ls_to_ps = Wls.create 17 in
(fun id cty gh lg ->
(fun id cty gh lg mf ->
let ps = {
ps_name = id;
ps_cty = cty;
ps_ghost = gh;
ps_logic = lg;
ps_name = id;
ps_cty = cty;
ps_ghost = gh;
ps_logic = lg;
ps_mfield = mf;
} in
match lg with
| PLls ls -> Wls.set ls_to_ps ls ps; ps
......@@ -62,7 +64,6 @@ type ps_kind =
| PKnone (* non-pure symbol *)
| PKpv of pvsymbol (* local let-function *)
| PKlocal (* new local let-function *)
| PKls of lsymbol (* top-level let-function or let-predicate *)
| PKfunc of int (* new top-level let-function or constructor *)
| PKpred (* new top-level let-predicate *)
| PKlemma (* top-level or local let-lemma *)
......@@ -90,7 +91,7 @@ let create_psymbol id ?(ghost=false) ?(kind=PKnone) c =
cty_add_post c [create_post res q] in
match kind with
| PKnone ->
mk_ps (id_register id) c ghost PLnone
mk_ps (id_register id) c ghost PLnone None
| PKlocal ->
check_effects c; check_reads c;
let ity = ity_purify c.cty_result in
......@@ -111,7 +112,7 @@ let create_psymbol id ?(ghost=false) ?(kind=PKnone) c =
this pvsymbol behaves exactly as Epure of its pv_vs. *)
let v = create_pvsymbol ~ghost:true id ity in
let t = t_func_app_l (t_var v.pv_vs) (arg_list c) in
mk_ps v.pv_vs.vs_name (add_post c t) ghost (PLpv v)
mk_ps v.pv_vs.vs_name (add_post c t) ghost (PLpv v) None
| PKpv v ->
check_effects c; check_reads c;
let ity = ity_purify c.cty_result in
......@@ -120,7 +121,7 @@ let create_psymbol id ?(ghost=false) ?(kind=PKnone) c =
ity_equal_check v.pv_ity ity;
if not v.pv_ghost then invalid_arg "Expr.create_psymbol";
let t = t_func_app_l (t_var v.pv_vs) (arg_list c) in
mk_ps (id_register id) (add_post c t) ghost (PLpv v)
mk_ps (id_register id) (add_post c t) ghost (PLpv v) None
| PKfunc constr ->
check_effects c; check_reads c;
(* we don't really need to check the well-formedness of
......@@ -128,7 +129,7 @@ let create_psymbol id ?(ghost=false) ?(kind=PKnone) c =
will take care of it *)
let ls = create_fsymbol id ~constr (arg_type c) (res_type c) in
let t = t_app ls (arg_list c) ls.ls_value in
mk_ps ls.ls_name (add_post c t) ghost (PLls ls)
mk_ps ls.ls_name (add_post c t) ghost (PLls ls) None
| PKpred ->
check_effects c; check_reads c;
if not (ity_equal c.cty_result ity_bool) then
......@@ -136,20 +137,22 @@ let create_psymbol id ?(ghost=false) ?(kind=PKnone) c =
it cannot be declared as a pure predicate";
let ls = create_psymbol id (arg_type c) in
let f = t_app ls (arg_list c) None in
mk_ps ls.ls_name (add_post c f) ghost (PLls ls)
| PKls ls when ls.ls_constr = 0 ->
check_effects c; check_reads c;
let args = arg_type c and res = res_type c in
List.iter2 ty_equal_check ls.ls_args args;
begin match ls.ls_value with
| None -> ty_equal_check ty_bool res
| Some ty -> ty_equal_check ty res end;
let t = t_app ls (arg_list c) ls.ls_value in
mk_ps (id_register id) (add_post c t) ghost (PLls ls)
| PKls _ -> invalid_arg "Expr.create_psymbol"
mk_ps ls.ls_name (add_post c f) ghost (PLls ls) None
| PKlemma ->
check_effects c;
mk_ps (id_register id) c ghost PLlemma
mk_ps (id_register id) c ghost PLlemma None
let create_mutable_field id s v =
if not (List.exists (fun u -> pv_equal u v) s.its_mfields) then
invalid_arg "Expr.create_mutable_field";
let ity = ity_app s (List.map ity_var s.its_ts.ts_args) s.its_regions in
let arg = create_pvsymbol (id_fresh "arg") ity in
let ls = create_fsymbol id [arg.pv_vs.vs_ty] v.pv_vs.vs_ty in
let res = create_vsymbol (id_fresh "result") v.pv_vs.vs_ty in
let t = fs_app ls [t_var arg.pv_vs] v.pv_vs.vs_ty in
let q = create_post res (t_equ (t_var res) t) in
let c = create_cty [arg] [] [q] Mexn.empty Spv.empty eff_empty v.pv_ity in
mk_ps ls.ls_name c v.pv_ghost (PLls ls) (Some v)
let ps_of_ls ls =
let v_args = List.map (fun ty ->
......@@ -163,14 +166,15 @@ let ps_of_ls ls =
| None ->
let res = create_vsymbol (id_fresh "result") ty_bool in
create_post res (t_iff (t_equ (t_var res) t_bool_true) t) in
let c = create_cty v_args [] [q] Mexn.empty
Spv.empty eff_empty (ity_of_ty (t_type q)) in
mk_ps ls.ls_name c false (PLls ls)
let ity = ity_of_ty (t_type q) in
let c = create_cty v_args [] [q] Mexn.empty Spv.empty eff_empty ity in
mk_ps ls.ls_name c false (PLls ls) None
let ps_kind ps = match ps.ps_logic with
| PLnone -> PKnone
| PLpv v -> PKpv v
| PLls s -> PKls s
| PLls {ls_value = None} -> PKpred
| PLls {ls_constr = cns} -> PKfunc cns
| PLlemma -> PKlemma
(** {2 Program patterns} *)
......@@ -243,7 +247,7 @@ type invariant = term
type variant = term * lsymbol option (** tau * (tau -> tau -> prop) *)
type assign = pvsymbol * pvsymbol * pvsymbol (* region * field * value *)
type assign = pvsymbol * psymbol * pvsymbol (* region * field * value *)
type vty =
| VtyI of ity
......@@ -403,10 +407,10 @@ let create_let_defn_ps id ?(ghost=false) ?(kind=PKnone) e =
let ghost = ghost || e.e_ghost in
let cty = match e.e_vty, kind with
| _, PKfunc n when n > 0 -> invalid_arg "Expr.create_let_defn_ps"
| VtyI i, (PKfunc _|PKpred|PKls _) when ity_immutable i ->
| VtyI i, (PKfunc _|PKpred) when ity_immutable i ->
(* the post will be equality to the logic constant *)
create_cty [] [] [] Mexn.empty Spv.empty eff_empty i
| VtyI _, (PKfunc _|PKpred|PKls _) -> Loc.errorm ?loc:e.e_loc
| VtyI _, (PKfunc _|PKpred) -> Loc.errorm ?loc:e.e_loc
"this expression is non-pure, it cannot be used as a pure function"
| VtyI _, (PKnone|PKlocal|PKpv _|PKlemma) -> Loc.errorm ?loc:e.e_loc
"this expression is first-order, it cannot be used as a function"
......@@ -502,16 +506,16 @@ let e_app e el ityl ity =
let e_assign_raw al =
let ghost = List.for_all (fun (r,f,v) ->
r.pv_ghost || f.pv_ghost || v.pv_ghost) al in
let conv (r,f,v) = match r.pv_ity.ity_node with
| Ityreg r -> r,f,v.pv_ity
r.pv_ghost || f.ps_ghost || v.pv_ghost) al in
let conv (r,f,v) = match r.pv_ity.ity_node, f.ps_mfield with
| Ityreg r, Some f -> r, f, v.pv_ity
| _ -> invalid_arg "Expr.e_assign" in
let eff = eff_assign eff_empty (List.map conv al) in
mk_expr (Eassign al) (VtyI ity_unit) ghost eff
let e_assign al =
let hr, hv, al = List.fold_right (fun (r,f,v) (hr,hv,al) ->
let ghost = r.e_ghost || f.pv_ghost || v.e_ghost in
let ghost = r.e_ghost || f.ps_ghost || v.e_ghost in
let hv, v = mk_proxy ~ghost v hv in
let hr, r = mk_proxy ~ghost r hr in
hr, hv, (r,f,v)::al) al ([],[],[]) in
......@@ -680,7 +684,7 @@ let rec check_expr gh mut vis rst e0 =
| Efun _ | Eany -> check_c rst (cty_of_expr e0)
| Eassign al ->
List.iter (fun (r,f,v) -> check_v rst r; check_v rst v;
if not f.pv_ghost && (gh || r.pv_ghost || v.pv_ghost)
if not f.ps_ghost && (gh || r.pv_ghost || v.pv_ghost)
then match r.pv_ity.ity_node with
| Ityreg r when Sreg.mem r vis -> error_r r
| _ -> ()) al
......@@ -876,6 +880,10 @@ let e_tuple el =
let ity = ity_tuple (List.map ity_of_expr el) in
e_app (e_sym (ps_tuple (List.length el))) el [] ity
let ps_void = ps_tuple 0
let e_void = e_app (e_sym ps_void) [] [] ity_unit
let ps_func_app = ps_of_ls fs_func_app
let e_func_app fn e =
......
......@@ -17,10 +17,11 @@ open Ity
(** {2 Program symbols} *)
type psymbol = private {
ps_name : ident;
ps_cty : cty;
ps_ghost : bool;
ps_logic : ps_logic;
ps_name : ident;
ps_cty : cty;
ps_ghost : bool;
ps_logic : ps_logic;
ps_mfield : pvsymbol option;
}
and ps_logic =
......@@ -42,7 +43,6 @@ type ps_kind =
| PKnone (* non-pure symbol *)
| PKpv of pvsymbol (* local let-function *)
| PKlocal (* new local let-function *)
| PKls of lsymbol (* top-level let-function or let-predicate *)
| PKfunc of int (* new top-level let-function or constructor *)
| PKpred (* new top-level let-predicate *)
| PKlemma (* top-level or local let-lemma *)
......@@ -57,6 +57,8 @@ val create_psymbol : preid -> ?ghost:bool -> ?kind:ps_kind -> cty -> psymbol
type must be [ity_bool]. If [?kind] is [PKlemma] and the result
type is not [ity_unit], an existential premise is generated. *)
val create_mutable_field : preid -> itysymbol -> pvsymbol -> psymbol
val restore_ps : lsymbol -> psymbol
(** raises [Not_found] if the argument is not a [ps_logic] *)
......@@ -94,7 +96,7 @@ type invariant = term
type variant = term * lsymbol option (** tau * (tau -> tau -> prop) *)
type assign = pvsymbol * pvsymbol * pvsymbol (* region * field * value *)
type assign = pvsymbol * psymbol * pvsymbol (* region * field * value *)
type vty =
| VtyI of ity
......@@ -201,7 +203,7 @@ val e_rec : rec_defn -> expr -> expr
val e_app : expr -> expr list -> ity list -> ity -> expr
val e_assign : (expr * pvsymbol (* field *) * expr) list -> expr
val e_assign : (expr * psymbol * expr) list -> expr
val e_ghost : expr -> expr
val e_ghostify : expr -> expr
......@@ -242,6 +244,9 @@ val e_bool_false : expr
val ps_tuple : int -> psymbol
val e_tuple : expr list -> expr
val ps_void : psymbol
val e_void : expr
val is_ps_tuple : psymbol -> bool
val ps_func_app : psymbol
......