Vc: Eif, Ecase, Eraise

src/mlw/ity.ml

@@ -1227,9 +1227,10 @@ let create_cty ?(mask=MaskVisible) args pre post xpost oldies effect result =
   let mask = mask_reduce mask in
   (* the arguments are pairwise distinct *)
   let sarg = List.fold_right (Spv.add_new exn) args Spv.empty in
-  (* drop unused or empty exceptional postconditions *)
-  let xpost = Mexn.set_inter xpost effect.eff_raises in
-  let xpost = Mexn.filter (fun _ l -> l <> []) xpost in
+  (* add empty and drop unused exceptional postconditions *)
+  let xpost = Mexn.merge (fun _ x q -> match x, q with
+    | Some (), Some _  -> q | Some (), None -> Some []
+    | None, _ -> None) effect.eff_raises xpost in
   (* complete the reads and freeze the external context.
      oldies must be fresh: collisions with args and external
      reads are forbidden, to simplify instantiation later. *)
@@ -1246,13 +1247,7 @@ let create_cty ?(mask=MaskVisible) args pre post xpost oldies effect result =
   let xreads = Spv.diff effect.eff_reads sarg in
   let freeze = Spv.fold freeze_pv xreads isb_empty in
   check_tvs effect.eff_reads result pre post xpost;
-  (* remove exceptions whose postcondition is False.
-     For a given function definition, we ensure both
-     cty.eff_raises and cty.xpost are in e.eff_raises,
-     where every postcondition missing in cty.xpost
-     is handled in a VC-specific way (e.g. as true),
-     and every exception missing in cty.eff_raises
-     has a false postcondition in cty.xpost. *)
+  (* remove exceptions whose postcondition is False *)
   let is_false q = match open_post q with
     | _, {t_node = Tfalse} -> true | _ -> false in
   let filter _ () = function

src/parser/parser.mly

@@ -827,13 +827,12 @@ ensures:
 
 raises:
 | uqualid ARROW term
-    { $1, mk_pat (Ptuple []) $startpos($1) $endpos($1), $3 }
+    { $1, Some (mk_pat (Ptuple []) $startpos($1) $endpos($1), $3) }
 | uqualid pat_arg ARROW term
-    { $1, $2, $4 }
+    { $1, Some ($2, $4) }
 
 xsymbol:
-| uqualid
-    { $1, mk_pat Pwild $startpos $endpos, mk_term Ttrue $startpos $endpos }
+| uqualid { $1, None }
 
 invariant:
 | INVARIANT LEFTBRC term RIGHTBRC { $3 }

src/parser/ptree.ml

@@ -93,7 +93,7 @@ type variant = (term * qualid option) list
 
 type pre = term
 type post = Loc.position * (pattern * term) list
-type xpost = Loc.position * (qualid * pattern * term) list
+type xpost = Loc.position * (qualid * (pattern * term) option) list
 
 type spec = {
   sp_pre     : pre list;

src/parser/typing.ml

@@ -475,12 +475,15 @@ let dpost muc ql lvm old ity =
   List.map dpost ql
 
 let dxpost muc ql lvm old =
-  let add_exn (q,pat,f) m =
+  let add_exn (q,pf) m =
     let xs = find_xsymbol muc q in
-    Mexn.change (function
-      | Some l -> Some ((pat,f) :: l)
-      | None   -> Some ((pat,f) :: [])) xs m in
+    Mexn.change (fun l -> match pf, l with
+      | Some pf, Some l -> Some (pf :: l)
+      | Some pf, None   -> Some (pf :: [])
+      | None,    None   -> Some []
+      | None,    Some _ -> l) xs m in
   let mk_xpost loc xs pfl =
+    if pfl = [] then [] else
     dpost muc [loc,pfl] lvm old xs.xs_ity in
   let exn_map (loc,xpfl) =
     let m = List.fold_right add_exn xpfl Mexn.empty in