Commit 17ed1270 authored by Raphael Rieu-Helft's avatar Raphael Rieu-Helft

Add support for partial functions

Program functions can be declared as partial with "let/val partial".
Similarly to "diverges", partial code cannot be ghost, however it does not need to be
explicitly specified as partial.

Fixes #184.
parent 8e5da6fb
val function partial f (x:int) : unit
\ No newline at end of file
val ghost partial f () : int
\ No newline at end of file
val partial random () : int
let ghost f () = random ()
val partial random () : int
let ghost f () = random ()
\ No newline at end of file
val partial f (x:int) : unit
let main () =
let ghost s = 3 in
f s;
42
\ No newline at end of file
let lemma partial f (x:int)
ensures { true }
= ()
\ No newline at end of file
let partial f () = 2
\ No newline at end of file
val partial random () : int
type t = { x: int } invariant { x = 0 } by { x = random () }
\ No newline at end of file
val partial random () : int
val f (x:int) : unit
use int.Int
let main () =
let r = random () in
let s = random () in
let ghost x = random () in
f x;
f r;
f x;
r * s
\ No newline at end of file
...@@ -120,6 +120,7 @@ let d2 : Ptree.decl = ...@@ -120,6 +120,7 @@ let d2 : Ptree.decl =
sp_variant = []; sp_variant = [];
sp_checkrw = false; sp_checkrw = false;
sp_diverge = false; sp_diverge = false;
sp_partial = false;
} }
in in
let body: expr = mk_expr Etrue in let body: expr = mk_expr Etrue in
...@@ -150,6 +151,7 @@ let d3 : Ptree.decl = ...@@ -150,6 +151,7 @@ let d3 : Ptree.decl =
sp_variant = []; sp_variant = [];
sp_checkrw = false; sp_checkrw = false;
sp_diverge = false; sp_diverge = false;
sp_partial = false;
} }
in in
let body: expr = mk_evar id_b in let body: expr = mk_evar id_b in
...@@ -184,6 +186,7 @@ let d1 : Ptree.decl = ...@@ -184,6 +186,7 @@ let d1 : Ptree.decl =
sp_variant = []; sp_variant = [];
sp_checkrw = false; sp_checkrw = false;
sp_diverge = false; sp_diverge = false;
sp_partial = false;
} }
in in
let body: expr = mk_expr (Ecast (mk_econst "42", PTtyapp (Qident a, []))) in let body: expr = mk_expr (Ecast (mk_econst "42", PTtyapp (Qident a, []))) in
......
...@@ -117,6 +117,7 @@ let d1 : decl = ...@@ -117,6 +117,7 @@ let d1 : decl =
sp_variant = []; sp_variant = [];
sp_checkrw = false; sp_checkrw = false;
sp_diverge = false; sp_diverge = false;
sp_partial = false;
} }
in in
let body = mk_eapp mul_int [mk_evar id_x; mk_econst "7"] in let body = mk_eapp mul_int [mk_evar id_x; mk_econst "7"] in
...@@ -163,6 +164,7 @@ let d2 = ...@@ -163,6 +164,7 @@ let d2 =
sp_variant = []; sp_variant = [];
sp_checkrw = false; sp_checkrw = false;
sp_diverge = false; sp_diverge = false;
sp_partial = false;
} }
in in
let body = let body =
...@@ -221,6 +223,7 @@ let d3 = ...@@ -221,6 +223,7 @@ let d3 =
sp_variant = []; sp_variant = [];
sp_checkrw = false; sp_checkrw = false;
sp_diverge = false; sp_diverge = false;
sp_partial = false;
} }
in in
let body = let body =
......
...@@ -79,6 +79,7 @@ let empty_spec = { ...@@ -79,6 +79,7 @@ let empty_spec = {
sp_variant = []; sp_variant = [];
sp_checkrw = false; sp_checkrw = false;
sp_diverge = false; sp_diverge = false;
sp_partial = false;
} }
type env = { type env = {
......
...@@ -38,7 +38,7 @@ ...@@ -38,7 +38,7 @@
sp_pre = []; sp_post = []; sp_xpost = []; sp_pre = []; sp_post = []; sp_xpost = [];
sp_reads = []; sp_writes = []; sp_alias = []; sp_reads = []; sp_writes = []; sp_alias = [];
sp_variant = []; sp_variant = [];
sp_checkrw = false; sp_diverge = false; sp_checkrw = false; sp_diverge = false; sp_partial = false;
} }
let spec_union s1 s2 = { let spec_union s1 s2 = {
...@@ -51,6 +51,7 @@ ...@@ -51,6 +51,7 @@
sp_variant = variant_union s1.sp_variant s2.sp_variant; sp_variant = variant_union s1.sp_variant s2.sp_variant;
sp_checkrw = s1.sp_checkrw || s2.sp_checkrw; sp_checkrw = s1.sp_checkrw || s2.sp_checkrw;
sp_diverge = s1.sp_diverge || s2.sp_diverge; sp_diverge = s1.sp_diverge || s2.sp_diverge;
sp_partial = s1.sp_partial || s2.sp_partial;
} }
%} %}
......
...@@ -25,7 +25,7 @@ ...@@ -25,7 +25,7 @@
(defconst why3-font-lock-keywords-1 (defconst why3-font-lock-keywords-1
(list (list
`(,(why3-regexp-opt '("invariant" "variant" "diverges" "requires" "ensures" "pure" "returns" "raises" "reads" "writes" "alias" "assert" "assume" "check")) . font-lock-type-face) `(,(why3-regexp-opt '("invariant" "variant" "diverges" "requires" "ensures" "pure" "returns" "raises" "reads" "writes" "alias" "assert" "assume" "check")) . font-lock-type-face)
`(,(why3-regexp-opt '("use" "clone" "scope" "import" "export" "coinductive" "inductive" "external" "constant" "function" "predicate" "val" "exception" "axiom" "lemma" "goal" "type" "mutable" "abstract" "private" "any" "match" "let" "rec" "in" "if" "then" "else" "begin" "end" "while" "for" "to" "downto" "do" "done" "loop" "absurd" "ghost" "raise" "return" "break" "continue" "try" "with" "theory" "uses" "module" "converter" "fun" "at" "old" "true" "false" "forall" "exists" "label" "by" "so" "meta")) . font-lock-keyword-face) `(,(why3-regexp-opt '("use" "clone" "scope" "import" "export" "coinductive" "inductive" "external" "constant" "function" "predicate" "val" "exception" "axiom" "lemma" "goal" "type" "mutable" "abstract" "private" "any" "match" "let" "rec" "in" "if" "then" "else" "begin" "end" "while" "for" "to" "downto" "do" "done" "loop" "absurd" "ghost" "partial" "raise" "return" "break" "continue" "try" "with" "theory" "uses" "module" "converter" "fun" "at" "old" "true" "false" "forall" "exists" "label" "by" "so" "meta")) . font-lock-keyword-face)
) )
"Minimal highlighting for Why3 mode") "Minimal highlighting for Why3 mode")
......
...@@ -93,7 +93,7 @@ syn keyword whyKeyword then type with ...@@ -93,7 +93,7 @@ syn keyword whyKeyword then type with
syn keyword whyKeyword abstract any break continue syn keyword whyKeyword abstract any break continue
syn keyword whyKeyword exception fun ghost label syn keyword whyKeyword exception fun ghost label
syn keyword whyKeyword model mutable private syn keyword whyKeyword model mutable partial private
syn keyword whyKeyword raise rec return val while syn keyword whyKeyword raise rec return val while
syn keyword whyBoolean true false syn keyword whyBoolean true false
......
...@@ -384,6 +384,7 @@ type dspec_final = { ...@@ -384,6 +384,7 @@ type dspec_final = {
ds_reads : pvsymbol list; ds_reads : pvsymbol list;
ds_writes : term list; ds_writes : term list;
ds_diverge : bool; ds_diverge : bool;
ds_partial : bool;
ds_checkrw : bool; ds_checkrw : bool;
} }
...@@ -892,6 +893,7 @@ let effect_of_dspec dsp = ...@@ -892,6 +893,7 @@ let effect_of_dspec dsp =
Loc.errorm ?loc:t.t_loc "mutable expression expected" in Loc.errorm ?loc:t.t_loc "mutable expression expected" in
let wl, eff = List.fold_left add_write ([], eff_read pvs) dsp.ds_writes in let wl, eff = List.fold_left add_write ([], eff_read pvs) dsp.ds_writes in
let eff = Mxs.fold (fun xs _ eff -> eff_raise eff xs) dsp.ds_xpost eff in let eff = Mxs.fold (fun xs _ eff -> eff_raise eff xs) dsp.ds_xpost eff in
let eff = if dsp.ds_partial then eff_partial eff else eff in
let eff = if dsp.ds_diverge then eff_diverge eff else eff in let eff = if dsp.ds_diverge then eff_diverge eff else eff in
wl, eff wl, eff
...@@ -924,8 +926,10 @@ let check_spec inr dsp ecty ({e_loc = loc} as e) = ...@@ -924,8 +926,10 @@ let check_spec inr dsp ecty ({e_loc = loc} as e) =
if check_ue && bad_raise ueff eeff then Loc.errorm ?loc if check_ue && bad_raise ueff eeff then Loc.errorm ?loc
"this@ expression@ does@ not@ raise@ exception@ %a" "this@ expression@ does@ not@ raise@ exception@ %a"
print_xs (Sxs.choose (Sxs.diff ueff.eff_raises eeff.eff_raises)); print_xs (Sxs.choose (Sxs.diff ueff.eff_raises eeff.eff_raises));
if check_ue && ueff.eff_oneway && not eeff.eff_oneway then Loc.errorm ?loc if check_ue && (diverges ueff.eff_oneway) && not (diverges eeff.eff_oneway)
"this@ expression@ does@ not@ diverge"; then Loc.errorm ?loc "this@ expression@ does@ not@ diverge";
if check_ue && (partial ueff.eff_oneway) && (ghostifiable eeff.eff_oneway)
then Loc.errorm ?loc "this@ expression's@ termination@ is@ not@ partial";
(* check that every computed effect is listed *) (* check that every computed effect is listed *)
if check_rw && bad_read eeff ueff then Loc.errorm ?loc if check_rw && bad_read eeff ueff then Loc.errorm ?loc
"this@ expression@ depends@ on@ variable@ %a,@ \ "this@ expression@ depends@ on@ variable@ %a,@ \
......
...@@ -76,6 +76,7 @@ type dspec_final = { ...@@ -76,6 +76,7 @@ type dspec_final = {
ds_reads : pvsymbol list; ds_reads : pvsymbol list;
ds_writes : term list; ds_writes : term list;
ds_diverge : bool; ds_diverge : bool;
ds_partial : bool;
ds_checkrw : bool; ds_checkrw : bool;
} }
......
...@@ -74,8 +74,10 @@ let rs_kind s = match s.rs_logic with ...@@ -74,8 +74,10 @@ let rs_kind s = match s.rs_logic with
let rs_ghost s = s.rs_cty.cty_effect.eff_ghost let rs_ghost s = s.rs_cty.cty_effect.eff_ghost
let check_effects ?loc c = let check_effects ?loc c =
if c.cty_effect.eff_oneway then Loc.errorm ?loc if diverges c.cty_effect.eff_oneway then Loc.errorm ?loc
"This function may not terminate, it cannot be used as pure"; "This function may not terminate, it cannot be used as pure";
if partial c.cty_effect.eff_oneway then Loc.errorm ?loc
"This function may fail, it cannot be used as pure";
if not (cty_pure c) then Loc.errorm ?loc if not (cty_pure c) then Loc.errorm ?loc
"This function has side effects, it cannot be used as pure" "This function has side effects, it cannot be used as pure"
...@@ -451,7 +453,7 @@ let localize_reset_stale v r el = ...@@ -451,7 +453,7 @@ let localize_reset_stale v r el =
(* localize a divergence *) (* localize a divergence *)
let localize_divergence el = let localize_divergence el =
let diverges eff = eff.eff_oneway in let diverges eff = diverges eff.eff_oneway in
List.iter (fun e -> if diverges e.e_effect then List.iter (fun e -> if diverges e.e_effect then
let loc = e_locate_effect diverges e in let loc = e_locate_effect diverges e in
Loc.error ?loc GhostDivergence) el; Loc.error ?loc GhostDivergence) el;
...@@ -1149,7 +1151,7 @@ let ls_decr_of_rec_defn = function ...@@ -1149,7 +1151,7 @@ let ls_decr_of_rec_defn = function
| { rec_rsym = {rs_cty = {cty_pre = {t_node = Tapp (ls,_)}::_}} } -> Some ls | { rec_rsym = {rs_cty = {cty_pre = {t_node = Tapp (ls,_)}::_}} } -> Some ls
| _ -> None | _ -> None
(* pretty-pringting *) (* pretty-printing *)
open Format open Format
open Pretty open Pretty
...@@ -1172,7 +1174,7 @@ let forget_let_defn = function ...@@ -1172,7 +1174,7 @@ let forget_let_defn = function
let print_rs fmt s = let print_rs fmt s =
Ident.print_decoded fmt (id_unique sprinter (id_of_rs s)) Ident.print_decoded fmt (id_unique sprinter (id_of_rs s))
let print_rs_head fmt s = fprintf fmt "%s%s%a%a" let print_rs_head fmt s = fprintf fmt "%s%s%s%a%a"
(if s.rs_cty.cty_effect.eff_ghost then "ghost " else "") (if s.rs_cty.cty_effect.eff_ghost then "ghost " else "")
(match s.rs_logic with (match s.rs_logic with
| RLnone -> "" | RLnone -> ""
...@@ -1180,6 +1182,7 @@ let print_rs_head fmt s = fprintf fmt "%s%s%a%a" ...@@ -1180,6 +1182,7 @@ let print_rs_head fmt s = fprintf fmt "%s%s%a%a"
| RLls {ls_value = None} -> "predicate " | RLls {ls_value = None} -> "predicate "
| RLls _ -> "function " | RLls _ -> "function "
| RLlemma -> "lemma ") | RLlemma -> "lemma ")
(if partial s.rs_cty.cty_effect.eff_oneway then "partial " else "")
print_rs s print_id_attrs (id_of_rs s) print_rs s print_id_attrs (id_of_rs s)
let print_invariant fmt fl = let print_invariant fmt fl =
......
...@@ -868,16 +868,30 @@ exception IllegalAssign of region * region * region ...@@ -868,16 +868,30 @@ exception IllegalAssign of region * region * region
exception ImpureVariable of tvsymbol * ity exception ImpureVariable of tvsymbol * ity
exception GhostDivergence exception GhostDivergence
type termination_status =
| Ghostifiable
| Partial
| Diverges
let ghostifiable status = (status = Ghostifiable)
let partial status = (status = Partial)
let diverges status = (status = Diverges)
let termination_union t1 t2 = match (t1, t2) with
| Ghostifiable, Ghostifiable -> Ghostifiable
| _, Diverges | Diverges, _ -> Diverges
| _ -> Partial
type effect = { type effect = {
eff_reads : Spv.t; (* known variables *) eff_reads : Spv.t; (* known variables *)
eff_writes : Spv.t Mreg.t; (* writes to fields *) eff_writes : Spv.t Mreg.t; (* writes to fields *)
eff_taints : Sreg.t; (* ghost code writes *) eff_taints : Sreg.t; (* ghost code writes *)
eff_covers : Sreg.t; (* surviving writes *) eff_covers : Sreg.t; (* surviving writes *)
eff_resets : Sreg.t; (* locked by covers *) eff_resets : Sreg.t; (* locked by covers *)
eff_raises : Sxs.t; (* raised exceptions *) eff_raises : Sxs.t; (* raised exceptions *)
eff_spoils : Stv.t; (* immutable tyvars *) eff_spoils : Stv.t; (* immutable tyvars *)
eff_oneway : bool; (* non-termination *) eff_oneway : termination_status; (* non-termination *)
eff_ghost : bool; (* ghost status *) eff_ghost : bool; (* ghost status *)
} }
let eff_empty = { let eff_empty = {
...@@ -888,7 +902,7 @@ let eff_empty = { ...@@ -888,7 +902,7 @@ let eff_empty = {
eff_resets = Sreg.empty; eff_resets = Sreg.empty;
eff_raises = Sxs.empty; eff_raises = Sxs.empty;
eff_spoils = Stv.empty; eff_spoils = Stv.empty;
eff_oneway = false; eff_oneway = Ghostifiable;
eff_ghost = false; eff_ghost = false;
} }
...@@ -906,7 +920,7 @@ let eff_equal e1 e2 = ...@@ -906,7 +920,7 @@ let eff_equal e1 e2 =
let eff_pure e = let eff_pure e =
Mreg.is_empty e.eff_writes && Mreg.is_empty e.eff_writes &&
Sxs.is_empty e.eff_raises && Sxs.is_empty e.eff_raises &&
not e.eff_oneway ghostifiable e.eff_oneway
let check_writes {eff_writes = wrt} pvs = let check_writes {eff_writes = wrt} pvs =
if not (Mreg.is_empty wrt) then Spv.iter (fun v -> if not (Mreg.is_empty wrt) then Spv.iter (fun v ->
...@@ -940,12 +954,12 @@ let reset_taints e = ...@@ -940,12 +954,12 @@ let reset_taints e =
let eff_ghostify gh e = let eff_ghostify gh e =
if not gh || e.eff_ghost then e else if not gh || e.eff_ghost then e else
if e.eff_oneway then raise GhostDivergence else if (not (ghostifiable e.eff_oneway)) then raise GhostDivergence else
reset_taints { e with eff_ghost = true } reset_taints { e with eff_ghost = true }
let eff_ghostify_weak gh e = let eff_ghostify_weak gh e =
if not gh || e.eff_ghost then e else if not gh || e.eff_ghost then e else
if e.eff_oneway || not (Sxs.is_empty e.eff_raises) then e else if not (ghostifiable e.eff_oneway && Sxs.is_empty e.eff_raises) then e else
if not (Sreg.equal e.eff_taints (visible_writes e)) then e else if not (Sreg.equal e.eff_taints (visible_writes e)) then e else
(* it is not enough to catch BadGhostWrite from eff_ghostify below, (* it is not enough to catch BadGhostWrite from eff_ghostify below,
because e may not have in eff_reads the needed visible variables because e may not have in eff_reads the needed visible variables
...@@ -953,9 +967,14 @@ let eff_ghostify_weak gh e = ...@@ -953,9 +967,14 @@ let eff_ghostify_weak gh e =
Therefore, we check that all visible writes are already taints. *) Therefore, we check that all visible writes are already taints. *)
eff_ghostify gh e eff_ghostify gh e
let eff_diverge e = if e.eff_oneway then e else let eff_partial e =
if diverges e.eff_oneway || partial e.eff_oneway then e
else if e.eff_ghost then raise GhostDivergence else
{ e with eff_oneway = Partial }
let eff_diverge e = if diverges e.eff_oneway then e else
if e.eff_ghost then raise GhostDivergence else if e.eff_ghost then raise GhostDivergence else
{ e with eff_oneway = true } { e with eff_oneway = Diverges }
let eff_read_pre rd e = let eff_read_pre rd e =
if Spv.subset rd e.eff_reads then e else if Spv.subset rd e.eff_reads then e else
...@@ -1077,7 +1096,7 @@ let eff_assign asl = ...@@ -1077,7 +1096,7 @@ let eff_assign asl =
eff_resets = resets; eff_resets = resets;
eff_raises = Sxs.empty; eff_raises = Sxs.empty;
eff_spoils = Stv.empty; eff_spoils = Stv.empty;
eff_oneway = false; eff_oneway = Ghostifiable;
eff_ghost = ghost } in eff_ghost = ghost } in
(* verify that we can rebuild every value *) (* verify that we can rebuild every value *)
check_writes effect reads; check_writes effect reads;
...@@ -1120,7 +1139,7 @@ let eff_union e1 e2 = { ...@@ -1120,7 +1139,7 @@ let eff_union e1 e2 = {
eff_resets = Sreg.union e1.eff_resets e2.eff_resets; eff_resets = Sreg.union e1.eff_resets e2.eff_resets;
eff_raises = Sxs.union e1.eff_raises e2.eff_raises; eff_raises = Sxs.union e1.eff_raises e2.eff_raises;
eff_spoils = Stv.union e1.eff_spoils e2.eff_spoils; eff_spoils = Stv.union e1.eff_spoils e2.eff_spoils;
eff_oneway = e1.eff_oneway || e2.eff_oneway; eff_oneway = termination_union e1.eff_oneway e2.eff_oneway;
eff_ghost = e1.eff_ghost && e2.eff_ghost } eff_ghost = e1.eff_ghost && e2.eff_ghost }
let eff_union e1 e2 = let eff_union e1 e2 =
...@@ -1481,8 +1500,10 @@ let cty_exec ({cty_effect = eff} as c) = ...@@ -1481,8 +1500,10 @@ let cty_exec ({cty_effect = eff} as c) =
in the resulting pvsymbol. Thus, we have to forbid all effects, in the resulting pvsymbol. Thus, we have to forbid all effects,
including allocation. TODO/FIXME: we should probably forbid including allocation. TODO/FIXME: we should probably forbid
the rest of the signature to contain regions at all. *) the rest of the signature to contain regions at all. *)
if eff.eff_oneway then Loc.errorm if (diverges eff.eff_oneway) then Loc.errorm
"This function may not terminate, it cannot be used as pure"; "This function may not terminate, it cannot be used as pure";
if (partial eff.eff_oneway) then Loc.errorm
"This function may fail, it cannot be used as pure";
if not (eff_pure eff && Sreg.is_empty eff.eff_resets) then Loc.errorm if not (eff_pure eff && Sreg.is_empty eff.eff_resets) then Loc.errorm
"This function has side effects, it cannot be used as pure"; "This function has side effects, it cannot be used as pure";
if not (Mreg.is_empty c.cty_freeze.isb_reg) then Loc.errorm if not (Mreg.is_empty c.cty_freeze.isb_reg) then Loc.errorm
...@@ -1679,7 +1700,7 @@ let print_spec args pre post xpost oldies eff fmt ity = ...@@ -1679,7 +1700,7 @@ let print_spec args pre post xpost oldies eff fmt ity =
fprintf fmt "@[<hov 4>@[%a@]%a@]" fprintf fmt "@[<hov 4>@[%a@]%a@]"
(Pp.print_list_pre Pp.space print_pvty) args (Pp.print_list_pre Pp.space print_pvty) args
(Pp.print_option print_result) ity; (Pp.print_option print_result) ity;
if eff.eff_oneway then pp_print_string fmt " diverges"; if diverges eff.eff_oneway then pp_print_string fmt " diverges";
let reads = List.fold_right Spv.remove args eff.eff_reads in let reads = List.fold_right Spv.remove args eff.eff_reads in
if not (Spv.is_empty reads) then fprintf fmt "@\nreads { @[%a@] }" if not (Spv.is_empty reads) then fprintf fmt "@\nreads { @[%a@] }"
(Pp.print_list Pp.comma print_pv) (Spv.elements reads); (Pp.print_list Pp.comma print_pv) (Spv.elements reads);
......
...@@ -339,16 +339,25 @@ exception IllegalAssign of region * region * region ...@@ -339,16 +339,25 @@ exception IllegalAssign of region * region * region
exception ImpureVariable of tvsymbol * ity exception ImpureVariable of tvsymbol * ity
exception GhostDivergence exception GhostDivergence
type termination_status =
| Ghostifiable
| Partial
| Diverges
val ghostifiable : termination_status -> bool
val partial : termination_status -> bool
val diverges : termination_status -> bool
type effect = private { type effect = private {
eff_reads : Spv.t; (* known variables *) eff_reads : Spv.t; (* known variables *)
eff_writes : Spv.t Mreg.t; (* writes to fields *) eff_writes : Spv.t Mreg.t; (* writes to fields *)
eff_taints : Sreg.t; (* ghost code writes *) eff_taints : Sreg.t; (* ghost code writes *)
eff_covers : Sreg.t; (* surviving writes *) eff_covers : Sreg.t; (* surviving writes *)
eff_resets : Sreg.t; (* locked by covers *) eff_resets : Sreg.t; (* locked by covers *)
eff_raises : Sxs.t; (* raised exceptions *) eff_raises : Sxs.t; (* raised exceptions *)
eff_spoils : Stv.t; (* immutable tyvars *) eff_spoils : Stv.t; (* immutable tyvars *)
eff_oneway : bool; (* non-termination *) eff_oneway : termination_status; (* non-termination *)
eff_ghost : bool; (* ghost status *) eff_ghost : bool; (* ghost status *)
} }
val eff_empty : effect val eff_empty : effect
...@@ -377,9 +386,10 @@ val eff_catch : effect -> xsymbol -> effect ...@@ -377,9 +386,10 @@ val eff_catch : effect -> xsymbol -> effect
val eff_spoil : effect -> ity -> effect val eff_spoil : effect -> ity -> effect
val eff_diverge : effect -> effect (* forbidden if ghost *) val eff_partial : effect -> effect (* forbidden if ghost *)
val eff_ghostify : bool -> effect -> effect (* forbidden if diverges *) val eff_diverge : effect -> effect (* forbidden if ghost *)
val eff_ghostify_weak : bool -> effect -> effect (* only if has no effect *) val eff_ghostify : bool -> effect -> effect (* forbidden if fails or diverges *)
val eff_ghostify_weak : bool -> effect -> effect (* only if has no effect *)
val eff_union_seq : effect -> effect -> effect (* checks for stale variables *) val eff_union_seq : effect -> effect -> effect (* checks for stale variables *)
val eff_union_par : effect -> effect -> effect (* no stale-variable check *) val eff_union_par : effect -> effect -> effect (* no stale-variable check *)
......
...@@ -88,8 +88,10 @@ let create_plain_record_decl ~priv ~mut id args fdl invl witn = ...@@ -88,8 +88,10 @@ let create_plain_record_decl ~priv ~mut id args fdl invl witn =
[create_constructor ~constr:1 cid s fdl] in [create_constructor ~constr:1 cid s fdl] in
if witn <> [] then begin if witn <> [] then begin
List.iter2 (fun fd ({e_loc = loc} as e) -> List.iter2 (fun fd ({e_loc = loc} as e) ->
if e.e_effect.eff_oneway then Loc.errorm ?loc if diverges e.e_effect.eff_oneway then Loc.errorm ?loc
"This expression may not terminate, it cannot be a witness"; "This expression may not terminate, it cannot be a witness";
if partial e.e_effect.eff_oneway then Loc.errorm ?loc
"This expression may fail, it cannot be a witness";
if not (eff_pure e.e_effect) then Loc.errorm ?loc if not (eff_pure e.e_effect) then Loc.errorm ?loc
"This expression has side effects, it cannot be a witness"; "This expression has side effects, it cannot be a witness";
let ety = ty_of_ity e.e_ity and fty = fd.pv_vs.vs_ty in let ety = ty_of_ity e.e_ity and fty = fd.pv_vs.vs_ty in
...@@ -539,7 +541,8 @@ let create_let_decl ld = ...@@ -539,7 +541,8 @@ let create_let_decl ld =
Loc.error ?loc:ls.ls_name.id_loc (Decl.NoTerminationProof ls) in Loc.error ?loc:ls.ls_name.id_loc (Decl.NoTerminationProof ls) in
let is_trusted_rec = match ld with let is_trusted_rec = match ld with
| LDrec ({rec_sym = {rs_logic = RLls ls; rs_cty = c}; rec_varl = []}::_) | LDrec ({rec_sym = {rs_logic = RLls ls; rs_cty = c}; rec_varl = []}::_)
when not c.cty_effect.eff_oneway -> abst = [] || fail_trusted_rec ls when ghostifiable c.cty_effect.eff_oneway ->
abst = [] || fail_trusted_rec ls
| _ -> false in | _ -> false in
let defn = if defn = [] then [] else let defn = if defn = [] then [] else
let dl = List.map (fun (s,vl,t) -> make_ls_defn s vl t) defn in let dl = List.map (fun (s,vl,t) -> make_ls_defn s vl t) defn in
......
...@@ -730,7 +730,8 @@ let clone_cty cl sm ?(drop_decr=false) cty = ...@@ -730,7 +730,8 @@ let clone_cty cl sm ?(drop_decr=false) cty =
let eff = eff_reset (eff_write reads writes) resets in let eff = eff_reset (eff_write reads writes) resets in
let add_raise xs eff = eff_raise eff (sm_find_xs sm xs) in let add_raise xs eff = eff_raise eff (sm_find_xs sm xs) in
let eff = Sxs.fold add_raise cty.cty_effect.eff_raises eff in let eff = Sxs.fold add_raise cty.cty_effect.eff_raises eff in
let eff = if cty.cty_effect.eff_oneway then eff_diverge eff else eff in let eff = if partial cty.cty_effect.eff_oneway then eff_partial eff else eff in
let eff = if diverges cty.cty_effect.eff_oneway then eff_diverge eff else eff in
let cty = create_cty ~mask:cty.cty_mask args pre post xpost olds eff res in let cty = create_cty ~mask:cty.cty_mask args pre post xpost olds eff res in
cty_ghostify (cty_ghost cty) cty cty_ghostify (cty_ghost cty) cty
......
...@@ -538,7 +538,7 @@ let rec k_expr env lps e res xmap = ...@@ -538,7 +538,7 @@ let rec k_expr env lps e res xmap =
Kseq (k_expr env lps e v xmap, 0, k v) in Kseq (k_expr env lps e v xmap, 0, k v) in
let var_or_proxy = var_or_proxy_case xmap in let var_or_proxy = var_or_proxy_case xmap in
let check_divergence k = let check_divergence k =
if eff.eff_oneway && not env.divergent then begin if diverges eff.eff_oneway && not env.divergent then begin
if Debug.test_noflag debug_ignore_diverges then if Debug.test_noflag debug_ignore_diverges then
Warning.emit ?loc "termination@ of@ this@ expression@ \ Warning.emit ?loc "termination@ of@ this@ expression@ \
cannot@ be@ proved,@ but@ there@ is@ no@ `diverges'@ \ cannot@ be@ proved,@ but@ there@ is@ no@ `diverges'@ \
......
...@@ -43,6 +43,7 @@ ...@@ -43,6 +43,7 @@
"match", MATCH; "match", MATCH;
"meta", META; "meta", META;
"not", NOT; "not", NOT;
"partial", PARTIAL;
"predicate", PREDICATE; "predicate", PREDICATE;
"range", RANGE; "range", RANGE;