Ity: remove restrictions from "strong updates"

src/mlw/dexpr.ml

@@ -778,7 +778,7 @@ let rec effect_of_term t =
         | Some _ -> assert false
         | None -> ity in
       begin try match ity.ity_node, restore_ps fs with
-        | Ityreg _, ({ps_mfield = Some _} as ps) -> v, ity, Some ps
+        | Ityreg _, ({ps_field = Some _} as ps) -> v, ity, Some ps
         | _, {ps_cty={cty_args=[arg]; cty_result=res; cty_freeze=frz}} ->
             v, ity_full_inst (ity_match frz arg.pv_ity ity) res, None
         | _ -> quit () with Not_found -> quit () end
@@ -797,9 +797,9 @@ let effect_of_dspec dsp =
   let add_write (s,l,e) t = match effect_of_term t with
     | v, {ity_node = Ityreg reg}, fd ->
         let fs = match fd with
-          | Some fd -> Spv.singleton (Opt.get fd.ps_mfield)
+          | Some fd -> Spv.singleton (Opt.get fd.ps_field)
           | None -> Spv.of_list reg.reg_its.its_mfields in
-        let wr = eff_write eff_empty reg fs in
+        let wr = Loc.try3 ?loc:t.t_loc eff_write eff_empty reg fs in
         Spv.add v s, (wr,t)::l, eff_union e wr
     | _ ->
         Loc.errorm ?loc:t.t_loc "mutable expression expected" in

src/mlw/expr.ml

@@ -18,11 +18,11 @@ open Ity
 (** {2 Program symbols} *)
 
 type psymbol = {
-  ps_name   : ident;
-  ps_cty    : cty;
-  ps_ghost  : bool;
-  ps_logic  : ps_logic;
-  ps_mfield : pvsymbol option;
+  ps_name  : ident;
+  ps_cty   : cty;
+  ps_ghost : bool;
+  ps_logic : ps_logic;
+  ps_field : pvsymbol option;
 }
 
 and ps_logic =
@@ -49,11 +49,11 @@ let mk_ps, restore_ps =
   let ls_to_ps = Wls.create 17 in
   (fun id cty gh lg mf ->
     let ps = {
-      ps_name   = id;
-      ps_cty    = cty;
-      ps_ghost  = gh;
-      ps_logic  = lg;
-      ps_mfield = mf;
+      ps_name  = id;
+      ps_cty   = cty;
+      ps_ghost = gh;
+      ps_logic = lg;
+      ps_field = mf;
     } in
     match lg with
     | PLls ls -> Wls.set ls_to_ps ls ps; ps
@@ -142,9 +142,10 @@ let create_psymbol id ?(ghost=false) ?(kind=PKnone) c =
       check_effects c;
       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 create_field id s v =
+  if not (List.exists (fun u -> pv_equal u v) s.its_mfields ||
+          List.exists (fun u -> pv_equal u v) s.its_ifields) then
+    invalid_arg "Expr.create_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
@@ -507,10 +508,10 @@ 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.ps_ghost || v.pv_ghost) al in
-  let conv (r,f,v) = match r.pv_ity.ity_node, f.ps_mfield with
+  let conv (r,f,v) = match r.pv_ity.ity_node, f.ps_field with
     | Ityreg r, Some f -> r, f, v.pv_ity
     | Ityreg {reg_its = s}, None -> Loc.errorm
-        "Type constructor %a has no mutable fields named %s"
+        "Type constructor %a has no fields named %s"
         Ity.print_its s f.ps_name.id_string
     | _ -> Loc.errorm "Mutable expression expected" in
   let eff = eff_assign eff_empty (List.map conv al) in

src/mlw/expr.mli

@@ -17,11 +17,11 @@ open Ity
 (** {2 Program symbols} *)
 
 type psymbol = private {
-  ps_name   : ident;
-  ps_cty    : cty;
-  ps_ghost  : bool;
-  ps_logic  : ps_logic;
-  ps_mfield : pvsymbol option;
+  ps_name  : ident;
+  ps_cty   : cty;
+  ps_ghost : bool;
+  ps_logic : ps_logic;
+  ps_field : pvsymbol option;
 }
 
 and ps_logic =
@@ -57,7 +57,7 @@ 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 create_field : preid -> itysymbol -> pvsymbol -> psymbol
 
 val restore_ps : lsymbol -> psymbol
 (** raises [Not_found] if the argument is not a [ps_logic] *)

src/mlw/ity.mli

@@ -19,11 +19,13 @@ type itysymbol = private {
   its_ts      : tysymbol;       (** pure "snapshot" type symbol *)
   its_private : bool;           (** is a private/abstract type *)
   its_mutable : bool;           (** is a record with mutable fields *)
-  its_mfields : pvsymbol list;  (** mutable fields *)
+  its_mfields : pvsymbol list;  (** mutable fields of a mutable type *)
+  its_ifields : pvsymbol list;  (** immutable fields of a mutable type *)
   its_regions : region list;    (** mutable shareable components *)
   its_reg_vis : bool list;      (** non-ghost shareable components *)
   its_arg_vis : bool list;      (** non-ghost type parameters *)
   its_arg_upd : bool list;      (** updatable type parameters *)
+  its_arg_exp : bool list;      (** exposed type parameters *)
   its_def     : ity option;     (** is a type alias *)
 }
 
@@ -96,9 +98,9 @@ exception UnboundRegion of region
 
 (** creation of a symbol for type in programs *)
 val create_itysymbol :
-  preid -> (tvsymbol * bool * bool) list ->
+  preid -> (tvsymbol * bool * bool * bool) list ->
     bool -> bool -> (region * bool) list ->
-    Spv.t -> ity option -> itysymbol
+    bool Mpv.t -> ity option -> itysymbol
 
 val restore_its : tysymbol -> itysymbol
 (** raises [Not_found] if the argument is not a [its_ts] *)
@@ -159,8 +161,10 @@ val reg_r_fold : ('a -> region -> 'a) -> 'a -> region -> 'a
 (** {2 Miscellaneous type utilities} *)
 
 val ity_freevars : Stv.t -> ity -> Stv.t
+val reg_freevars : Stv.t -> region -> Stv.t
 
 val ity_v_occurs : tvsymbol -> ity -> bool
+val reg_v_occurs : tvsymbol -> region -> bool
 
 val ity_r_occurs : region -> ity -> bool
 val reg_r_occurs : region -> region -> bool
@@ -266,6 +270,10 @@ val eff_union : effect -> effect -> effect
 val eff_is_empty : effect -> bool
 val eff_is_pure  : effect -> bool
 
+exception AssignPrivate of region
+exception DuplicateField of region * pvsymbol
+exception WriteImmutable of region * pvsymbol
+
 val eff_write : effect -> region -> Spv.t -> effect
 val eff_raise : effect -> xsymbol -> effect
 val eff_catch : effect -> xsymbol -> effect