switch the interface for type_expr from Internal.(lock|unlock) to Pri…

…vate_type_expr.(create|set_*)

ocamldoc/odoc_misc.ml

@@ -509,5 +509,5 @@ let remove_option typ =
     | Types.Tlink t2
     | Types.Tsubst t2 -> iter t2.Types.desc
   in
-  Types.Internal.lock
-    { (Types.Internal.unlock typ) with Types.Internal.desc = iter typ.Types.desc }
+  Types.Private_type_expr.create (iter typ.Types.desc)
+    ~level:typ.Types.level ~scope:typ.Types.scope ~id:typ.Types.id

ocamldoc/odoc_print.ml

@@ -87,11 +87,12 @@ let simpl_class_type t =
         (* we delete vals and methods in order to not print them when
            displaying the type *)
       let tself =
-        let open Types.Internal in
-        lock { (unlock cs.Types.csig_self) with
-               desc = Types.Tobject
-                 (lock { desc = Types.Tnil ; level = 0 ;
-                         scope = Btype.lowest_level ; id = 0 }, ref None) }
+        let t = cs.Types.csig_self in
+        let t' = Types.Private_type_expr.create Types.Tnil
+            ~level:0 ~scope:Btype.lowest_level ~id:0 in
+        let desc = Types.Tobject (t', ref None) in
+        Types.Private_type_expr.create desc
+          ~level:t.Types.level ~scope:t.Types.scope ~id:t.Types.id
       in
         Types.Cty_signature { Types.csig_self = tself;
                               csig_vars = Types.Vars.empty ;

typing/btype.ml

@@ -568,7 +568,7 @@ end
 let not_marked_node ty = ty.level >= lowest_level
     (* type nodes with negative levels are "marked" *)
 
-let flip_mark_node ty = (Internal.unlock ty).level <- pivot_level - ty.level
+let flip_mark_node ty = Private_type_expr.set_level ty (pivot_level - ty.level)
 
 let try_mark_node ty = not_marked_node ty && (flip_mark_node ty; true)
 
@@ -595,7 +595,7 @@ let rec unmark_type ty =
   let ty = repr ty in
   if ty.level < lowest_level then begin
     (* flip back the marked level *)
-    (Internal.unlock ty).level <- mirror_level ty.level;
+    flip_mark_node ty;
     iter_type_expr unmark_type ty
   end
 
@@ -723,10 +723,10 @@ let extract_label l ls = extract_label_aux [] l ls
                   (**********************************)
 
 let undo_change = function
-    Ctype  (ty, desc) -> (Internal.unlock ty).desc <- desc
-  | Ccompress  (ty, desc, _) -> (Internal.unlock ty).desc <- desc
-  | Clevel (ty, level) -> (Internal.unlock ty).level <- level
-  | Cscope (ty, scope) -> (Internal.unlock ty).scope <- scope
+    Ctype  (ty, desc) -> Private_type_expr.set_desc ty desc
+  | Ccompress  (ty, desc, _) -> Private_type_expr.set_desc ty desc
+  | Clevel (ty, level) -> Private_type_expr.set_level ty level
+  | Cscope (ty, scope) -> Private_type_expr.set_scope ty scope
   | Cname  (r, v) -> r := v
   | Crow   (r, v) -> r := v
   | Ckind  (r, v) -> r := v
@@ -742,17 +742,17 @@ let log_type ty =
 let link_type ty ty' =
   log_type ty;
   let desc = ty.desc in
-  (Internal.unlock ty).desc <- Tlink ty';
+  Private_type_expr.set_desc ty (Tlink ty');
   (* Name is a user-supplied name for this unification variable (obtained
    * through a type annotation for instance). *)
   match desc, ty'.desc with
     Tvar name, Tvar name' ->
       begin match name, name' with
-      | Some _, None ->  log_type ty'; (Internal.unlock ty').desc <- Tvar name
+      | Some _, None ->  log_type ty'; Private_type_expr.set_desc ty' (Tvar name)
       | None, Some _ ->  ()
       | Some _, Some _ ->
           if ty.level < ty'.level then
-            (log_type ty'; (Internal.unlock ty').desc <- Tvar name)
+            (log_type ty'; Private_type_expr.set_desc ty' (Tvar name))
       | None, None   ->  ()
       end
   | _ -> ()
@@ -762,20 +762,20 @@ let link_type ty ty' =
 let set_type_desc ty td =
   if td != ty.desc then begin
     log_type ty;
-    (Internal.unlock ty).desc <- td
+    Private_type_expr.set_desc ty td
   end
 (* TODO: separate set_level into two specific functions: *)
 (*  set_lower_level and set_generic_level *)
  let set_level ty level =
   if level <> ty.level then begin
     if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));
-    (Internal.unlock ty).level <- level
+    Private_type_expr.set_level ty level
   end
 (* TODO: introduce a guard and rename it to set_higher_scope? *)
 let set_scope ty scope =
   if scope <> ty.scope then begin
     if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope));
-    (Internal.unlock ty).scope <- scope
+    Private_type_expr.set_scope ty scope
   end
 let set_univar rty ty =
   log_change (Cuniv (rty, !rty)); rty := Some ty
@@ -839,6 +839,6 @@ let undo_compress (changes, _old) =
       List.iter
         (fun r -> match !r with
           Change (Ccompress (ty, desc, d), next) when ty.desc == d ->
-            (Internal.unlock ty).desc <- desc; r := !next
+            Private_type_expr.set_desc ty desc; r := !next
         | _ -> ())
         log

typing/ctype.ml

@@ -1153,8 +1153,8 @@ let rec copy ?partial ?keep_names scope ty =
     For_copy.save_desc scope ty desc;
     let t = newvar() in          (* Stub *)
     set_scope t ty.scope;
-    (Internal.unlock ty).desc <- Tsubst t;
-    (Internal.unlock t).desc <-
+    Private_type_expr.set_desc ty (Tsubst t);
+    Private_type_expr.set_desc t
       begin match desc with
       | Tconstr (p, tl, _) ->
           let abbrevs = proper_abbrevs p tl !abbreviations in
@@ -1184,7 +1184,7 @@ let rec copy ?partial ?keep_names scope ty =
           begin match more.desc with
             Tsubst {desc = Ttuple [_;ty2]} ->
               (* This variant type has been already copied *)
-              (Internal.unlock ty).desc <- Tsubst ty2;
+              Private_type_expr.set_desc ty (Tsubst ty2);
               (* avoid Tlink in the new type *)
               Tlink ty2
           | _ ->
@@ -1234,7 +1234,7 @@ let rec copy ?partial ?keep_names scope ty =
                 | _ -> (more', row)
               in
               (* Register new type first for recursion *)
-              (Internal.unlock more).desc <- Tsubst(newgenty(Ttuple[more';t]));
+              Private_type_expr.set_desc more (Tsubst(newgenty(Ttuple[more';t])));
               (* Return a new copy *)
               Tvariant (copy_row copy true row keep more')
           end
@@ -1434,7 +1434,7 @@ let rec copy_sep cleanup_scope fixed free bound visited ty =
     if ty.level <> generic_level then ty else
     let t = newvar () in
     delayed_copy :=
-      lazy ((Internal.unlock t).desc <- Tlink (copy cleanup_scope ty))
+      lazy (Private_type_expr.set_desc t (Tlink (copy cleanup_scope ty)))
       :: !delayed_copy;
     t
   else try
@@ -1452,7 +1452,7 @@ let rec copy_sep cleanup_scope fixed free bound visited ty =
           visited
     in
     let copy_rec = copy_sep cleanup_scope fixed free bound visited in
-    (Internal.unlock t).desc <-
+    Private_type_expr.set_desc t
       begin match ty.desc with
       | Tvariant row0 ->
           let row = row_repr row0 in
@@ -2057,7 +2057,7 @@ let polyfy env ty vars =
     | Tvar name when ty.level = generic_level ->
         For_copy.save_desc scope ty ty.desc;
         let t = newty (Tunivar name) in
-        (Internal.unlock ty).desc <- Tsubst t;
+        Private_type_expr.set_desc ty (Tsubst t);
         Some t
     | _ -> None
   in
@@ -2556,7 +2556,7 @@ let unify1_var env t1 t2 =
     update_level env t1.level t2;
     update_scope t1.scope t2
   with Unify _ as e ->
-    (Internal.unlock t1).desc <- d1;
+    Private_type_expr.set_desc t1 d1;
     raise e
 
 (* Can only be called when generate_equations is true *)
@@ -2844,7 +2844,7 @@ and unify3 env t1 t1' t2 t2' =
         | _ ->
             () (* t2 has already been expanded by update_level *)
     with Unify trace ->
-      (Internal.unlock t1').desc <- d1;
+      Private_type_expr.set_desc t1' d1;
       raise (Unify trace)
   end
 

typing/datarepr.ml

@@ -180,8 +180,8 @@ let extension_descr ~current_unit path_ext ext =
       cstr_uid = ext.ext_uid;
     }
 
-let none = Internal.lock
- {desc = Ttuple []; level = -1; scope = Btype.generic_level; id = -1}
+let none = Private_type_expr.create (Ttuple [])
+    ~level:(-1) ~scope:Btype.generic_level ~id:(-1)
                                         (* Clearly ill-formed type *)
 let dummy_label =
   { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;

typing/subst.ml

@@ -131,8 +131,7 @@ let reset_for_saving () = new_id := -1
 
 let newpersty desc =
   decr new_id;
-  Internal.lock
-    { desc; level = generic_level; scope = Btype.lowest_level; id = !new_id }
+  Private_type_expr.create desc ~level:generic_level ~scope:Btype.lowest_level ~id:!new_id
 
 (* ensure that all occurrences of 'Tvar None' are physically shared *)
 let tvar_none = Tvar None
@@ -155,7 +154,7 @@ let rec typexp copy_scope s ty =
           else newty2 ty.level desc
         in
         For_copy.save_desc copy_scope ty desc;
-        (Internal.unlock ty).desc <- Tsubst ty';
+        Private_type_expr.set_desc ty (Tsubst ty');
         (* TODO: move this line to btype.ml
            there is a similar problem also in ctype.ml *)
         ty'
@@ -178,10 +177,10 @@ let rec typexp copy_scope s ty =
       not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in
     (* Make a stub *)
     let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
-    (Internal.unlock ty').scope <- ty.scope;
+    Private_type_expr.set_scope ty' ty.scope;
     (* TODO: figure out why not use set_scope *)
-    (Internal.unlock ty).desc <- Tsubst ty';
-    (Internal.unlock ty').desc <-
+    Private_type_expr.set_desc ty (Tsubst ty');
+    Private_type_expr.set_desc ty'
       begin if has_fixed_row then
         match tm.desc with (* PR#7348 *)
           Tconstr (Pdot(m,i), tl, _abbrev) ->
@@ -218,7 +217,7 @@ let rec typexp copy_scope s ty =
           begin match more.desc with
             Tsubst {desc = Ttuple [_;ty2]} ->
               (* This variant type has been already copied *)
-              (Internal.unlock ty).desc <- Tsubst ty2;
+              Private_type_expr.set_desc ty (Tsubst ty2);
               (* avoid Tlink in the new type *)
               Tlink ty2
           | _ ->
@@ -237,8 +236,8 @@ let rec typexp copy_scope s ty =
                 | _ -> assert false
               in
               (* Register new type first for recursion *)
-              (Internal.unlock more).desc <-
-                Tsubst(newgenty(Ttuple[more';ty']));
+              Private_type_expr.set_desc more
+                (Tsubst(newgenty(Ttuple[more';ty'])));
               (* TODO: check if more' can be eliminated *)
               (* Return a new copy *)
               let row =