Commit 14e70649 authored by Andrei Paskevich's avatar Andrei Paskevich

Merge branch 'improve_diverges_effect'

parents d1bb2ed9 b12336ca
val partial function f (x:int) : unit
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 partial lemma f (x:int)
ensures { true }
= ()
module S
val constant c : int
val f () : int
end
module I2
val partial random () : int
clone export S with val f = random
end
\ 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 && total eeff.eff_oneway
then Loc.errorm ?loc "this@ expression@ does@ not@ diverge@ or@ fail";
(* 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,8 +1174,9 @@ let forget_let_defn = function ...@@ -1172,8 +1174,9 @@ 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 "")
(if partial s.rs_cty.cty_effect.eff_oneway then "partial " else "")
(match s.rs_logic with (match s.rs_logic with
| RLnone -> "" | RLnone -> ""
| RLpv _ -> "function " | RLpv _ -> "function "
......
...@@ -868,6 +868,21 @@ exception IllegalAssign of region * region * region ...@@ -868,6 +868,21 @@ exception IllegalAssign of region * region * region
exception ImpureVariable of tvsymbol * ity exception ImpureVariable of tvsymbol * ity
exception GhostDivergence exception GhostDivergence
(* termination status *)
type oneway =
| Total
| Partial
| Diverges
let total status = (status = Total)
let partial status = (status = Partial)
let diverges status = (status = Diverges)
let oneway_union t1 t2 = match t1, t2 with
| Total, Total -> Total
| _, 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 *)
...@@ -876,7 +891,7 @@ type effect = { ...@@ -876,7 +891,7 @@ type effect = {
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 : oneway; (* non-termination *)
eff_ghost : bool; (* ghost status *) eff_ghost : bool; (* ghost status *)
} }
...@@ -888,7 +903,7 @@ let eff_empty = { ...@@ -888,7 +903,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 = Total;
eff_ghost = false; eff_ghost = false;
} }
...@@ -906,7 +921,7 @@ let eff_equal e1 e2 = ...@@ -906,7 +921,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 total 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 +955,12 @@ let reset_taints e = ...@@ -940,12 +955,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 (total 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 (total 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 +968,15 @@ let eff_ghostify_weak gh e = ...@@ -953,9 +968,15 @@ 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 +1098,7 @@ let eff_assign asl = ...@@ -1077,7 +1098,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 = Total;
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 +1141,7 @@ let eff_union e1 e2 = { ...@@ -1120,7 +1141,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 = oneway_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 +1502,10 @@ let cty_exec ({cty_effect = eff} as c) = ...@@ -1481,8 +1502,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 +1702,7 @@ let print_spec args pre post xpost oldies eff fmt ity = ...@@ -1679,7 +1702,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,6 +339,16 @@ exception IllegalAssign of region * region * region ...@@ -339,6 +339,16 @@ exception IllegalAssign of region * region * region
exception ImpureVariable of tvsymbol * ity exception ImpureVariable of tvsymbol * ity
exception GhostDivergence exception GhostDivergence
(* termination status *)
type oneway =
| Total
| Partial
| Diverges
val total : oneway -> bool
val partial : oneway -> bool
val diverges : oneway -> 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 *)
...@@ -347,7 +357,7 @@ type effect = private { ...@@ -347,7 +357,7 @@ type effect = private {
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 : oneway; (* non-termination *)
eff_ghost : bool; (* ghost status *) eff_ghost : bool; (* ghost status *)
} }
...@@ -377,9 +387,10 @@ val eff_catch : effect -> xsymbol -> effect ...@@ -377,9 +387,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,7 @@ let create_let_decl ld = ...@@ -539,7 +541,7 @@ 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 total 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
......
...@@ -451,6 +451,8 @@ let empty_clones m = { ...@@ -451,6 +451,8 @@ let empty_clones m = {
xs_table = Mxs.empty; xs_table = Mxs.empty;
} }
exception CloneDivergence of ident * ident
(* populate the clone structure *) (* populate the clone structure *)
let rec sm_trans_ty tym tsm ty = match ty.ty_node with let rec sm_trans_ty tym tsm ty = match ty.ty_node with
...@@ -730,7 +732,8 @@ let clone_cty cl sm ?(drop_decr=false) cty = ...@@ -730,7 +732,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
...@@ -1052,6 +1055,11 @@ let clone_pdecl inst cl uc d = match d.pd_node with ...@@ -1052,6 +1055,11 @@ let clone_pdecl inst cl uc d = match d.pd_node with
| RLls ls, RLls ls' -> cl.ls_table <- Mls.add ls ls' cl.ls_table | RLls ls, RLls ls' -> cl.ls_table <- Mls.add ls ls' cl.ls_table
| _ -> raise (BadInstance rs.rs_name) | _ -> raise (BadInstance rs.rs_name)
end; end;
begin
match cty.cty_effect.eff_oneway, rs'.rs_cty.cty_effect.eff_oneway with
| _, Total | Diverges, _ | Partial, Partial -> ()
| _ -> raise (CloneDivergence (rs.rs_name, rs'.rs_name))
end;
cl.rs_table <- Mrs.add rs rs' cl.rs_table; cl.rs_table <- Mrs.add rs rs' cl.rs_table;
let e = e_exec (c_app rs' cty.cty_args [] cty.cty_result) in let e = e_exec (c_app rs' cty.cty_args [] cty.cty_result) in
let cexp = c_fun ~mask:cty.cty_mask cty.cty_args cty.cty_pre let cexp = c_fun ~mask:cty.cty_mask cty.cty_args cty.cty_pre
...@@ -1228,9 +1236,15 @@ let print_module fmt m = Format.fprintf fmt ...@@ -1228,9 +1236,15 @@ let print_module fmt m = Format.fprintf fmt
"@[<hov 2>module %s@\n%a@]@\nend" m.mod_theory.th_name.id_string "@[<hov 2>module %s@\n%a@]@\nend" m.mod_theory.th_name.id_string
(Pp.print_list Pp.newline2 print_unit) m.mod_units (Pp.print_list Pp.newline2 print_unit) m.mod_units
let print_id fmt id = Ident.print_decoded fmt id.id_string
let () = Exn_printer.register (fun fmt e -> match e with let () = Exn_printer.register (fun fmt e -> match e with
| IncompatibleNotation nm -> Format.fprintf fmt | IncompatibleNotation nm -> Format.fprintf fmt
"Incombatible type signatures for notation '%a'" Ident.print_decoded nm "Incombatible type signatures for notation '%a'" Ident.print_decoded nm
| ModuleNotFound (sl,s) -> Format.fprintf fmt | ModuleNotFound (sl,s) -> Format.fprintf fmt
"Module %s not found in library %a" s print_path sl "Module %s not found in library %a" s print_path sl
| CloneDivergence (iv, il) -> Format.fprintf fmt
"Cannot instantiate symbol %a with symbol %a \
that has worse termination status"
print_id iv print_id il
| _ -> raise e) | _ -> raise e)
...@@ -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;
"scope", SCOPE; "scope", SCOPE;