Support 'let open' in class and class type expressions (#1249)

* Support 'let open' in class and class type expressions.

* Adapt ocamlprof.

* Adapt ocamldoc.

* Add tests.

* Changelog.

* Manual.

32 files changed, 182 insertions, 14 deletions

diff --git a/Changes b/Changes
index 5ecdf45639..8376357080 100644
--- a/Changes
+++ b/Changes
@@ -9,6 +9,10 @@ Working version
   can be used as a placeholder for a polymorphic function.
   (Stephen Dolan)
 
+- GPR#1249, MPR#6271, MPR#7529: Support "let open M in ..."
+  in class expressions and class type expressions.
+  (Alain Frisch, reviews by Thomas Refis and Jacques Garrigue)
+
 ### Code generation and optimizations:
 
 - MPR#5324, GPR#375: An alternative Linear Scan register allocator for
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 03f575920d..e71e77fa7c 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -195,7 +195,8 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
         build_object_init cl_table obj (vals @ params) inh_init obj_init cl
       in
       (inh_init, Translcore.transl_let rec_flag defs obj_init)
-  | Tcl_constraint (cl, _, _vals, _pub_meths, _concr_meths) ->
+  | Tcl_open (_, _, _, _, cl)
+  | Tcl_constraint (cl, _, _, _, _) ->
       build_object_init cl_table obj params inh_init obj_init cl
 
 let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
@@ -386,6 +387,8 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
            Lsequence(mkappl (oo_prim "narrow", narrow_args),
                      cl_init))
       end
+  | Tcl_open (_, _, _, _, cl) ->
+      build_class_init cla cstr super inh_init cl_init msubst top cl
 
 let rec build_class_lets cl ids =
   match cl.cl_desc with
@@ -407,6 +410,7 @@ let rec get_class_meths cl =
   | Tcl_fun (_, _, _, cl, _)
   | Tcl_let (_, _, _, cl)
   | Tcl_apply (cl, _)
+  | Tcl_open (_, _, _, _, cl)
   | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl
 
 (*
@@ -452,6 +456,8 @@ let rec transl_class_rebind obj_init cl vf =
       in
       check_constraint cl.cl_type;
       (path, obj_init)
+  | Tcl_open (_, _, _, _, cl) ->
+      transl_class_rebind obj_init cl vf
 
 let rec transl_class_rebind_0 self obj_init cl vf =
   match cl.cl_desc with
diff --git a/manual/manual/refman/classes.etex b/manual/manual/refman/classes.etex
index d9f27d7402..2480357c9f 100644
--- a/manual/manual/refman/classes.etex
+++ b/manual/manual/refman/classes.etex
@@ -27,6 +27,7 @@ class-type:
 class-body-type:
       'object' ['(' typexpr ')'] {class-field-spec} 'end'
    |  ['[' typexpr {',' typexpr} ']'] classtype-path
+   |  'let' 'open' module-path 'in' class-body-type
 ;
 %\end{syntax} \begin{syntax}
 class-field-spec:
@@ -75,6 +76,10 @@ virtual method will match a concrete method, which makes it possible
 to forget its implementation. An immutable instance variable will match a
 mutable instance variable.
 
+\subsubsection*{Local opens}
+
+Local opens are supported in class types since OCaml 4.06.
+
 \subsubsection*{Inheritance}
 
 \ikwd{inherit\@\texttt{inherit}}
@@ -173,6 +178,7 @@ class-expr:
    |  'fun' {{parameter}} '->' class-expr
    |  'let' ['rec'] let-binding {'and' let-binding} 'in' class-expr
    |  'object' class-body 'end'
+   |  'let' 'open' module-path 'in' class-expr
 ;
 %BEGIN LATEX
 \end{syntax} \begin{syntax}
@@ -258,6 +264,9 @@ definition, it will be evaluated when the class is created (just as if
 the definition was outside of the class).
 Otherwise, it will be evaluated when the object constructor is called.
 
+\subsubsection*{Local opens}
+
+Local opens are supported in class expressions since OCaml 4.06.
 
 \subsubsection*{Class\label{ss:class-body} body}
 \begin{syntax}
diff --git a/manual/manual/refman/exten.etex b/manual/manual/refman/exten.etex
index 0fee6f5fc3..4b4ddb2e76 100644
--- a/manual/manual/refman/exten.etex
+++ b/manual/manual/refman/exten.etex
@@ -1020,6 +1020,15 @@ specification:
 expr:
        ...
      | 'let' 'open!' module-path 'in' expr
+;
+class-body-type:
+       ...
+   |  'let' 'open!' module-path 'in' class-body-type
+;
+class-expr:
+       ...
+   |  'let' 'open!' module-path 'in' class-expr
+;
 \end{syntax}
 
 Since OCaml 4.01, @"open"@ statements shadowing an existing identifier
@@ -1027,6 +1036,8 @@ Since OCaml 4.01, @"open"@ statements shadowing an existing identifier
 character after the @"open"@ keyword indicates that such a shadowing is
 intentional and should not trigger the warning.
 
+This is also available (since OCaml 4.06) for local opens in class
+expressions and class type expressions.
 
 \section{Generalized algebraic datatypes} \ikwd{type\@\texttt{type}}
 \ikwd{match\@\texttt{match}} \label{s:gadts}
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 5bc67b8016..925f95c508 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -606,6 +606,7 @@ module Analyser =
                     ic_text = text_opt ;
                   }
 
+              | Parsetree.Pcty_open _ (* one could also traverse the open *)
               | Parsetree.Pcty_signature _
               | Parsetree.Pcty_arrow _ ->
                     (* we don't have a name for the class signature, so we call it "object ... end"  *)
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index ac1fc40da5..4a0c78386d 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -286,6 +286,7 @@ module Cl = struct
   let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c))
   let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a)
+  let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_open (a, b, c))
 end
 
 module Cty = struct
@@ -301,6 +302,7 @@ module Cty = struct
   let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a)
   let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a)
+  let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_open (a, b, c))
 end
 
 module Ctf = struct
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 0a216bdb56..9a817883f9 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -353,6 +353,8 @@ module Cty:
     val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type ->
       class_type -> class_type
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
+    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type
+               -> class_type
   end
 
 (** Class type fields *)
@@ -391,6 +393,8 @@ module Cl:
     val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type ->
       class_expr
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
+    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr
+               -> class_expr
   end
 
 (** Class fields *)
diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
index 8518438d82..7323a5fa03 100755
--- a/parsing/ast_iterator.ml
+++ b/parsing/ast_iterator.ml
@@ -182,6 +182,8 @@ module CT = struct
     | Pcty_arrow (_lab, t, ct) ->
         sub.typ sub t; sub.class_type sub ct
     | Pcty_extension x -> sub.extension sub x
+    | Pcty_open (_ovf, lid, e) ->
+        iter_loc sub lid; sub.class_type sub e
 
   let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
     =
@@ -427,6 +429,8 @@ module CE = struct
     | Pcl_constraint (ce, ct) ->
         sub.class_expr sub ce; sub.class_type sub ct
     | Pcl_extension x -> sub.extension sub x
+    | Pcl_open (_ovf, lid, e) ->
+        iter_loc sub lid; sub.class_expr sub e
 
   let iter_kind sub = function
     | Cfk_concrete (_o, e) -> sub.expr sub e
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 4962cc2cdb..5c744a22f6 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -191,6 +191,8 @@ module CT = struct
     | Pcty_arrow (lab, t, ct) ->
         arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
     | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcty_open (ovf, lid, ct) ->
+        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct)
 
   let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
     =
@@ -451,6 +453,8 @@ module CE = struct
     | Pcl_constraint (ce, ct) ->
         constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
     | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcl_open (ovf, lid, ce) ->
+        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce)
 
   let map_kind sub = function
     | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
diff --git a/parsing/depend.ml b/parsing/depend.ml
index 7adb900ed1..910ad8992c 100644
--- a/parsing/depend.ml
+++ b/parsing/depend.ml
@@ -167,6 +167,8 @@ let rec add_class_type bv cty =
   | Pcty_arrow(_, ty1, cty2) ->
       add_type bv ty1; add_class_type bv cty2
   | Pcty_extension e -> handle_extension e
+  | Pcty_open (_ovf, m, e) ->
+      let bv = open_module bv m.txt in add_class_type bv e
 
 and add_class_type_field bv pctf =
   match pctf.pctf_desc with
@@ -502,6 +504,8 @@ and add_class_expr bv ce =
   | Pcl_constraint(ce, ct) ->
       add_class_expr bv ce; add_class_type bv ct
   | Pcl_extension e -> handle_extension e
+  | Pcl_open (_ovf, m, e) ->
+      let bv = open_module bv m.txt in add_class_expr bv e
 
 and add_class_field bv pcf =
   match pcf.pcf_desc with
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 2dc49aa420..451350afa1 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -260,6 +260,8 @@ let mkpat_attrs d attrs =
 
 let wrap_class_attrs body attrs =
   {body with pcl_attributes = attrs @ body.pcl_attributes}
+let wrap_class_type_attrs body attrs =
+  {body with pcty_attributes = attrs @ body.pcty_attributes}
 let wrap_mod_attrs body attrs =
   {body with pmod_attributes = attrs @ body.pmod_attributes}
 let wrap_mty_attrs body attrs =
@@ -1033,6 +1035,8 @@ class_expr:
       { mkclass(Pcl_apply($1, List.rev $2)) }
   | let_bindings IN class_expr
       { class_of_let_bindings $1 $3 }
+  | LET OPEN override_flag attributes mod_longident IN class_expr
+      { wrap_class_attrs (mkclass(Pcl_open($3, mkrhs $5 5, $7))) $4 }
   | class_expr attribute
       { Cl.attr $1 $2 }
   | extension
@@ -1165,6 +1169,8 @@ class_signature:
       { Cty.attr $1 $2 }
   | extension
       { mkcty(Pcty_extension $1) }
+  | LET OPEN override_flag attributes mod_longident IN class_signature
+      { wrap_class_type_attrs (mkcty(Pcty_open($3, mkrhs $5 5, $7))) $4 }
 ;
 class_sig_body:
     class_self_type class_sig_fields
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 1155ddc9ec..e1961aae42 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -501,6 +501,8 @@ and class_type_desc =
          *)
   | Pcty_extension of extension
         (* [%id] *)
+  | Pcty_open of override_flag * Longident.t loc * class_type
+        (* let open M in CT *)
 
 and class_signature =
     {
@@ -590,7 +592,10 @@ and class_expr_desc =
   | Pcl_constraint of class_expr * class_type
         (* (CE : CT) *)
   | Pcl_extension of extension
-        (* [%id] *)
+  (* [%id] *)
+  | Pcl_open of override_flag * Longident.t loc * class_expr
+  (* let open M in CE *)
+
 
 and class_structure =
     {
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 1b38fe461f..fe3c84d577 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -795,6 +795,9 @@ and class_type ctxt f x =
   | Pcty_extension e ->
       extension ctxt f e;
       attributes ctxt f x.pcty_attributes
+  | Pcty_open (ovf, lid, e) ->
+      pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
+        (class_type ctxt) e
 
 (* [class type a = object end] *)
 and class_type_declaration_list ctxt f l =
@@ -911,6 +914,9 @@ and class_expr ctxt f x =
           (class_expr ctxt) ce
           (class_type ctxt) ct
     | Pcl_extension e -> extension ctxt f e
+    | Pcl_open (ovf, lid, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
+          (class_expr ctxt) e
 
 and module_type ctxt f x =
   if x.pmty_attributes <> [] then begin
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 6e167b3e47..73d9d7a21c 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -482,6 +482,10 @@ and class_type i ppf x =
   | Pcty_extension (s, arg) ->
       line i ppf "Pcty_extension \"%s\"\n" s.txt;
       payload i ppf arg
+  | Pcty_open (ovf, m, e) ->
+      line i ppf "Pcty_open %a \"%a\"\n" fmt_override_flag ovf
+        fmt_longident_loc m;
+      class_type i ppf e
 
 and class_signature i ppf cs =
   line i ppf "class_signature\n";
@@ -569,6 +573,10 @@ and class_expr i ppf x =
   | Pcl_extension (s, arg) ->
       line i ppf "Pcl_extension \"%s\"\n" s.txt;
       payload i ppf arg
+  | Pcl_open (ovf, m, e) ->
+      line i ppf "Pcl_open %a \"%a\"\n" fmt_override_flag ovf
+        fmt_longident_loc m;
+      class_expr i ppf e
 
 and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
   line i ppf "class_structure\n";
diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml
index 99ecea98af..ef67a9746a 100644
--- a/testsuite/tests/parsetree/source.ml
+++ b/testsuite/tests/parsetree/source.ml
@@ -7298,3 +7298,18 @@ fun contents -> {contents=contents[@foo]};;
 (* https://github.com/LexiFi/gen_js_api/issues/61 *)
 
 let () = foo##.bar := ();;
+
+(* "let open" in classes and class types *)
+
+class c =
+  let open M in
+  object
+    method f : t = x
+  end
+;;
+class type ct =
+  let open M in
+  object
+    method f : t
+  end
+;;
diff --git a/testsuite/tests/typing-objects/open_in_classes.ml b/testsuite/tests/typing-objects/open_in_classes.ml
new file mode 100755
index 0000000000..24c0b34dfe
--- /dev/null
+++ b/testsuite/tests/typing-objects/open_in_classes.ml
@@ -0,0 +1,17 @@
+module M = struct
+  type t = int
+  let x = 42
+end
+;;
+class c =
+  let open M in
+  object
+    method f : t = x
+  end
+;;
+class type ct =
+  let open M in
+  object
+    method f : t
+  end
+;;
diff --git a/testsuite/tests/typing-objects/open_in_classes.ml.reference b/testsuite/tests/typing-objects/open_in_classes.ml.reference
new file mode 100644
index 0000000000..eaafa30f16
--- /dev/null
+++ b/testsuite/tests/typing-objects/open_in_classes.ml.reference
@@ -0,0 +1,5 @@
+
+#         module M : sig type t = int val x : int end
+#           class c : object method f : M.t end
+#           class type ct = object method f : M.t end
+# 
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index fb08ffd5ea..2e72d52cf0 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -367,6 +367,7 @@ and rewrite_class_expr iflag cexpr =
   | Pcl_let (_, spat_sexp_list, cexpr) ->
       rewrite_patexp_list iflag spat_sexp_list;
       rewrite_class_expr iflag cexpr
+  | Pcl_open (_, _, cexpr)
   | Pcl_constraint (cexpr, _) ->
       rewrite_class_expr iflag cexpr
   | Pcl_extension _ -> ()
diff --git a/typing/env.ml b/typing/env.ml
index a1105fab89..c5e26fc1e4 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -2078,17 +2078,21 @@ let open_pers_signature name env =
   | Some env -> env
   | None -> assert false (* a compilation unit cannot refer to a functor *)
 
-let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root env =
+let open_signature
+    ?(used_slot = ref false)
+    ?(loc = Location.none) ?(toplevel = false) ovf root env =
   if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
      && (Warnings.is_active (Warnings.Unused_open "")
          || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
          || Warnings.is_active (Warnings.Open_shadow_label_constructor ("","")))
   then begin
-    let used = ref false in
+    let used = used_slot in
     !add_delayed_check_forward
       (fun () ->
-        if not !used then
-          Location.prerr_warning loc (Warnings.Unused_open (Path.name root))
+         if not !used then begin
+           used := true;
+           Location.prerr_warning loc (Warnings.Unused_open (Path.name root))
+         end
       );
     let shadowed = ref [] in
     let slot s b =
diff --git a/typing/env.mli b/typing/env.mli
index ff737e3e89..f96c76b7c1 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -156,6 +156,7 @@ val add_signature: signature -> t -> t
    Used to implement open. Returns None if the path refers to a functor,
    not a structure. *)
 val open_signature:
+    ?used_slot:bool ref ->
     ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t ->
       t -> t option
 
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index 78e1b60a5b..0609504b8e 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -479,6 +479,9 @@ and class_type i ppf x =
       arg_label i ppf l;
       core_type i ppf co;
       class_type i ppf cl;
+  | Tcty_open (ovf, m, _, _, e) ->
+      line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
+      class_type i ppf e
 
 and class_signature i ppf { csig_self = ct; csig_fields = l } =
   line i ppf "class_signature\n";
@@ -560,6 +563,9 @@ and class_expr i ppf x =
       class_expr i ppf ce;
       class_type i ppf ct
   | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce
+  | Tcl_open (ovf, m, _, _, e) ->
+      line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
+      class_expr i ppf e
 
 and class_structure i ppf { cstr_self = p; cstr_fields = l } =
   line i ppf "class_structure\n";
diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml
index 0873dd4c9e..ce67092958 100644
--- a/typing/tast_mapper.ml
+++ b/typing/tast_mapper.ml
@@ -521,6 +521,8 @@ let class_expr sub x =
         )
     | Tcl_ident (path, lid, tyl) ->
         Tcl_ident (path, lid, List.map (sub.typ sub) tyl)
+    | Tcl_open (ovf, p, lid, env, e) ->
+        Tcl_open (ovf, p, lid, sub.env sub env, sub.class_expr sub e)
   in
   {x with cl_desc; cl_env}
 
@@ -541,6 +543,8 @@ let class_type sub x =
            sub.typ sub ct,
            sub.class_type sub cl
           )
+    | Tcty_open (ovf, p, lid, env, e) ->
+        Tcty_open (ovf, p, lid, sub.env sub env, sub.class_type sub e)
   in
   {x with cltyp_desc; cltyp_env}
 
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 51f8a256dc..f3b10dd75f 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -540,6 +540,12 @@ and class_type env scty =
       let clty = class_type env scty in
       let typ = Cty_arrow (l, ty, clty.cltyp_type) in
       cltyp (Tcty_arrow (l, cty, clty)) typ
+
+  | Pcty_open (ovf, lid, e) ->
+      let (path, newenv) = !Typecore.type_open ovf env scty.pcty_loc lid in
+      let clty = class_type newenv e in
+      cltyp (Tcty_open (ovf, path, lid, newenv, clty)) clty.cltyp_type
+
   | Pcty_extension ext ->
       raise (Error_forward (Builtin_attributes.error_of_extension ext))
 
@@ -1191,6 +1197,17 @@ and class_expr cl_num val_env met_env scl =
           cl_env = val_env;
           cl_attributes = scl.pcl_attributes;
          }
+  | Pcl_open (ovf, lid, e) ->
+      let used_slot = ref false in
+      let (path, new_val_env) = !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc lid in
+      let (_path, new_met_env) = !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc lid in
+      let cl = class_expr cl_num new_val_env new_met_env e in
+      rc {cl_desc = Tcl_open (ovf, path, lid, new_val_env, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
   | Pcl_extension ext ->
       raise (Error_forward (Builtin_attributes.error_of_extension ext))
 
@@ -1704,6 +1721,7 @@ let rec unify_parents env ty cl =
       | _exn -> assert false
       end
   | Tcl_structure st -> unify_parents_struct env ty st
+  | Tcl_open (_, _, _, _, cl)
   | Tcl_fun (_, _, _, cl, _)
   | Tcl_apply (cl, _)
   | Tcl_let (_, _, _, cl)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index d76710f1de..a1e47a10e6 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -89,8 +89,11 @@ let type_module =
 
 (* Forward declaration, to be filled in by Typemod.type_open *)
 
-let type_open =
-  ref (fun _ -> assert false)
+let type_open :
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
+    ref =
+  ref (fun ?used_slot:_ _ -> assert false)
 
 (* Forward declaration, to be filled in by Typemod.type_package *)
 
@@ -220,6 +223,7 @@ let iter_expression f e =
         class_expr ce; List.iter (fun (_, e) -> expr e) lel
     | Pcl_let (_, pel, ce) ->
         List.iter binding pel; class_expr ce
+    | Pcl_open (_, _, ce)
     | Pcl_constraint (ce, _) -> class_expr ce
     | Pcl_extension _ -> ()
 
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 7b64ee343c..b9ad77bff9 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -135,7 +135,8 @@ val report_error: Env.t -> formatter -> error -> unit
 val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
 (* Forward declaration, to be filled in by Typemod.type_open *)
 val type_open:
-    (override_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t)
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
     ref
 (* Forward declaration, to be filled in by Typeclass.class_structure *)
 val type_object:
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index db4440c18f..02888dfdad 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -153,6 +153,7 @@ and class_expr_desc =
   | Tcl_constraint of
       class_expr * class_type option * string list * string list * Concr.t
     (* Visible instance variables, methods and concretes methods *)
+  | Tcl_open of override_flag * Path.t * Longident.t loc * Env.t * class_expr
 
 and class_structure =
   {
@@ -478,6 +479,7 @@ and class_type_desc =
     Tcty_constr of Path.t * Longident.t loc * core_type list
   | Tcty_signature of class_signature
   | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type
 
 and class_signature = {
     csig_self: core_type;
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index ee26bca3e1..261b4a4bc2 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -267,7 +267,8 @@ and class_expr_desc =
                   (Ident.t * string loc * expression) list * class_expr
   | Tcl_constraint of
       class_expr * class_type option * string list * string list * Concr.t
-    (* Visible instance variables, methods and concretes methods *)
+  (* Visible instance variables, methods and concretes methods *)
+  | Tcl_open of override_flag * Path.t * Longident.t loc * Env.t * class_expr
 
 and class_structure =
   {
@@ -600,6 +601,7 @@ and class_type_desc =
     Tcty_constr of Path.t * Longident.t loc * core_type list
   | Tcty_signature of class_signature
   | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type
 
 and class_signature = {
     csig_self : core_type;
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index fd04e55210..5babcea065 100644
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -511,6 +511,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
 
         | Tcl_ident (_, _, tyl) ->
             List.iter iter_core_type tyl
+
+        | Tcl_open (_, _, _, _, e) ->
+            iter_class_expr e
       end;
       Iter.leave_class_expr cexpr;
 
@@ -524,6 +527,8 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Tcty_arrow (_label, ct, cl) ->
             iter_core_type ct;
             iter_class_type cl
+        | Tcty_open (_, _, _, _, e) ->
+            iter_class_type e
       end;
       Iter.leave_class_type ct;
 
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index 58249be2a6..58983a11b8 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -566,7 +566,9 @@ module MakeMap(Map : MapArgument) = struct
                            Some (map_class_type clty), vals, meths, concrs)
 
         | Tcl_ident (id, name, tyl) ->
-          Tcl_ident (id, name, List.map map_core_type tyl)
+            Tcl_ident (id, name, List.map map_core_type tyl)
+        | Tcl_open (ovf, p, lid, env, e) ->
+            Tcl_open (ovf, p, lid, env, map_class_expr e)
     in
     Map.leave_class_expr { cexpr with cl_desc = cl_desc }
 
@@ -579,6 +581,8 @@ module MakeMap(Map : MapArgument) = struct
           Tcty_constr (path, lid, List.map map_core_type list)
         | Tcty_arrow (label, ct, cl) ->
           Tcty_arrow (label, map_core_type ct, map_class_type cl)
+        | Tcty_open (ovf, p, lid, env, e) ->
+          Tcty_open (ovf, p, lid, env, map_class_type e)
     in
     Map.leave_class_type { ct with cltyp_desc = cltyp_desc }
 
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 376128be6e..175442869d 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -82,9 +82,9 @@ let extract_sig_open env loc mty =
 
 (* Compute the environment after opening a module *)
 
-let type_open_ ?toplevel ovf env loc lid =
+let type_open_ ?used_slot ?toplevel ovf env loc lid =
   let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in
-  match Env.open_signature ~loc ?toplevel ovf path env with
+  match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with
   | Some env -> path, env
   | None ->
       let md = Env.find_module path env in
diff --git a/typing/typemod.mli b/typing/typemod.mli
index fbda10b5e8..b975eb2ac0 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -36,7 +36,7 @@ val transl_signature:
 val check_nongen_schemes:
         Env.t -> Types.signature -> unit
 val type_open_:
-        ?toplevel:bool -> Asttypes.override_flag ->
+        ?used_slot:bool ref -> ?toplevel:bool -> Asttypes.override_flag ->
         Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t
 val modtype_of_package:
         Env.t -> Location.t ->
diff --git a/typing/untypeast.ml b/typing/untypeast.ml
index 0cb58f484a..10f4271b54 100644
--- a/typing/untypeast.ml
+++ b/typing/untypeast.ml
@@ -634,6 +634,9 @@ let class_expr sub cexpr =
     | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
         Pcl_constraint (sub.class_expr sub cl,  sub.class_type sub clty)
 
+    | Tcl_open (ovf, _p, lid, _env, e) ->
+        Pcl_open (ovf, lid, sub.class_expr sub e)
+
     | Tcl_ident _ -> assert false
     | Tcl_constraint (_, None, _, _, _) -> assert false
   in
@@ -648,6 +651,8 @@ let class_type sub ct =
         Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list)
     | Tcty_arrow (label, ct, cl) ->
         Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl)
+    | Tcty_open (ovf, _p, lid, _env, e) ->
+        Pcty_open (ovf, lid, sub.class_type sub e)
   in
   Cty.mk ~loc ~attrs desc