Change representation of class signatures

Changes

@@ -451,6 +451,9 @@ OCaml 4.13.0
 
 ### Internal/compiler-libs changes:
 
+- #8516: Change representation of class signatures
+  (Leo White, review by Thomas Refis)
+
 - #9243, simplify parser rules for array indexing operations
   (Florian Angeletti, review by Damien Doligez and Gabriel Scherer)
 

lambda/translclass.ml

@@ -351,8 +351,8 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl =
       (inh_init, transl_vals cla true StrictOpt vals cl_init)
   | Tcl_constraint (cl, _, vals, meths, concr_meths) ->
       let virt_meths =
-        List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
-      let concr_meths = Concr.elements concr_meths in
+        List.filter (fun lab -> not (MethSet.mem lab concr_meths)) meths in
+      let concr_meths = MethSet.elements concr_meths in
       let narrow_args =
         [Lvar cla;
          transl_meth_list vals;

lambda/translcore.ml

@@ -462,17 +462,26 @@ and transl_exp0 ~in_new_scope ~scopes e =
   | Texp_for(param, _, low, high, dir, body) ->
       Lfor(param, transl_exp ~scopes low, transl_exp ~scopes high, dir,
            event_before ~scopes body (transl_exp ~scopes body))
-  | Texp_send(_, _, Some exp) -> transl_exp ~scopes exp
-  | Texp_send(expr, met, None) ->
-      let obj = transl_exp ~scopes expr in
-      let loc = of_location ~scopes e.exp_loc in
+  | Texp_send(expr, met) ->
       let lam =
+        let loc = of_location ~scopes e.exp_loc in
         match met with
-          Tmeth_val id -> Lsend (Self, Lvar id, obj, [], loc)
+        | Tmeth_val id ->
+            let obj = transl_exp ~scopes expr in
+            Lsend (Self, Lvar id, obj, [], loc)
         | Tmeth_name nm ->
+            let obj = transl_exp ~scopes expr in
             let (tag, cache) = Translobj.meth obj nm in
             let kind = if cache = [] then Public else Cached in
             Lsend (kind, tag, obj, cache, loc)
+        | Tmeth_ancestor(meth, path_self) ->
+            let self = transl_value_path loc e.exp_env path_self in
+            Lapply {ap_loc = loc;
+                    ap_func = Lvar meth;
+                    ap_args = [self];
+                    ap_tailcall = Default_tailcall;
+                    ap_inlined = Default_inline;
+                    ap_specialised = Default_specialise}
       in
       event_after ~scopes e lam
   | Texp_new (cl, {Location.loc=loc}, _) ->
@@ -510,10 +519,9 @@ and transl_exp0 ~in_new_scope ~scopes e =
              ap_specialised=Default_specialise;
            },
            List.fold_right
-             (fun (path, _, expr) rem ->
-               let var = transl_value_path loc e.exp_env path in
+             (fun (id, _, expr) rem ->
                 Lsequence(transl_setinstvar ~scopes Loc_unknown
-                            (Lvar cpy) var expr, rem))
+                            (Lvar cpy) (Lvar id) expr, rem))
              modifs
              (Lvar cpy))
   | Texp_letmodule(None, loc, Mp_present, modl, body) ->

ocamldoc/.depend

@@ -514,7 +514,6 @@ odoc_misc.cmo : \
     odoc_types.cmi \
     odoc_messages.cmo \
     ../parsing/longident.cmi \
-    ../typing/ctype.cmi \
     ../typing/btype.cmi \
     odoc_misc.cmi
 odoc_misc.cmx : \
@@ -524,7 +523,6 @@ odoc_misc.cmx : \
     odoc_types.cmx \
     odoc_messages.cmx \
     ../parsing/longident.cmx \
-    ../typing/ctype.cmx \
     ../typing/btype.cmx \
     odoc_misc.cmi
 odoc_misc.cmi : \

ocamldoc/odoc_misc.ml

@@ -87,22 +87,6 @@ let rec string_of_longident li =
   | Longident.Lapply(l1, l2) ->
       string_of_longident l1 ^ "(" ^ string_of_longident l2 ^ ")"
 
-let get_fields type_expr =
-  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields type_expr) in
-  List.fold_left
-    (fun acc -> fun (label, field_kind, typ) ->
-      match field_kind with
-        Types.Fabsent ->
-          acc
-      | _ ->
-          if label = "*dummy method*" then
-            acc
-          else
-            acc @ [label, typ]
-    )
-    []
-    fields
-
 let rec string_of_text t =
   let rec iter t_ele =
     match t_ele with

ocamldoc/odoc_misc.mli

@@ -29,10 +29,6 @@ val split_with_blanks : string -> string list
 (** This function creates a string from a Longident.t .*)
 val string_of_longident : Longident.t -> string
 
-(** This function returns the list of (label, type_expr) describing
-   the methods of a type_expr in a Tobject.*)
-val get_fields : Types.type_expr -> (string * Types.type_expr) list
-
 (** get a string from a text *)
 val string_of_text : Odoc_types.text -> string
 

ocamldoc/odoc_print.ml

@@ -87,23 +87,21 @@ let simpl_class_type t =
     | Cty_signature cs ->
         (* we delete vals and methods in order to not print them when
            displaying the type *)
+      let self_row =
+        Transient_expr.create Tnil
+          ~level:0 ~scope:Btype.lowest_level ~id:0
+      in
       let tself =
         let t = cs.csig_self in
-        let t' = Transient_expr.create Tnil
-            ~level:0 ~scope:Btype.lowest_level ~id:0 in
-        let desc =
-          Tobject (Transient_expr.type_expr t', ref None) in
+        let desc = Tobject (Transient_expr.type_expr self_row, ref None) in
         Transient_expr.create desc
-          ~level:(get_level t)
-          ~scope:(get_scope t)
-          ~id:(get_id t)
+          ~level:(get_level t) ~scope:(get_scope t) ~id:(get_id t)
       in
-        Cty_signature { csig_self = Transient_expr.type_expr tself;
+        Types.Cty_signature { csig_self = Transient_expr.type_expr tself;
+                              csig_self_row = Transient_expr.type_expr self_row;
                               csig_vars = Vars.empty ;
-                              csig_concr = Concr.empty ;
-                              csig_inher = []
-                             }
-    | Cty_arrow (l, texp, ct) ->
+                              csig_meths = Meths.empty ; }
+    | Types.Cty_arrow (l, texp, ct) ->
         let new_ct = iter ct in
         Cty_arrow (l, texp, new_ct)
   in

ocamldoc/odoc_sig.ml

@@ -104,8 +104,8 @@ module Signature_search =
       type_expr
 
     let search_method_type name class_sig =
-      let fields = Odoc_misc.get_fields class_sig.Types.csig_self in
-      List.assoc name fields
+      let (_, _, type_expr) = Types.Meths.find name class_sig.Types.csig_meths in
+      type_expr
   end
 
 module type Info_retriever =

testsuite/tests/typing-gadts/pr7260.ml

@@ -19,13 +19,12 @@ class foo =
 type bar = < bar : unit >
 type _ ty = Int : int ty
 type dyn = Dyn : 'a ty -> dyn
-Lines 7-12, characters 0-5:
- 7 | class foo =
- 8 |   object (this)
+Lines 8-12, characters 2-5:
+ 8 | ..object (this)
  9 |     method foo (Dyn ty) =
 10 |       match ty with
 11 |       | Int -> (this :> bar)
 12 |   end.................................
-Error: This class should be virtual.
-       The following methods are undefined : bar
+Error: This non-virtual class has undeclared virtual methods.
+       The following methods were not declared : bar
 |}];;

testsuite/tests/typing-gadts/pr7391.ml

@@ -29,7 +29,7 @@ class virtual child2 :
   object ('a)
     method private virtual parent : < previous : 'a option; .. >
   end
-- : < child : child2; previous : child2 option > = <obj>
+- : < child : child1; previous : child1 option > = <obj>
 |}]
 
 (* Worked in 4.03 *)
@@ -43,7 +43,7 @@ let _ =
       end
   end;;
 [%%expect{|
-- : < child : unit -> child2; previous : child2 option > = <obj>
+- : < child : unit -> child1; previous : child1 option > = <obj>
 |}]
 
 (* Worked in 4.03 *)
@@ -57,7 +57,7 @@ let _ =
       end
   end;;
 [%%expect{|
-- : < child : unit -> child2; previous : child2 option > = <obj>
+- : < child : unit -> child1; previous : child1 option > = <obj>
 |}]
 
 (* Didn't work in 4.03, but works in 4.07 *)
@@ -73,7 +73,7 @@ let _ =
       in o
   end;;
 [%%expect{|
-- : < child : child2; previous : child2 option > = <obj>
+- : < child : child1; previous : child1 option > = <obj>
 |}]
 
 (* Also didn't work in 4.03 *)
@@ -91,5 +91,5 @@ let _ =
   end;;
 [%%expect{|
 type gadt = Not_really_though : gadt
-- : < child : gadt -> child2; previous : child2 option > = <obj>
+- : < child : gadt -> child1; previous : child1 option > = <obj>
 |}]

testsuite/tests/typing-misc/exotic_unifications.ml

@@ -9,9 +9,9 @@ class x = object(self: <x:int; ..>)
 end
 [%%expect {|
 class virtual t : object method virtual x : float end
-Line 4, characters 16-17:
+Line 4, characters 8-17:
 4 |         inherit t
-                    ^
+            ^^^^^^^^^
 Error: The method x has type int but is expected to have type float
        Type int is not compatible with type float
 |}]

testsuite/tests/typing-misc/includeclass_errors.ml

@@ -146,7 +146,8 @@ Lines 2-5, characters 4-7:
 3 |         method foo = "foo"
 4 |         method private virtual cast: int
 5 |     end
-Error: The class type object method foo : string end
+Error: The class type
+         object method private virtual cast : int method foo : string end
        is not matched by the class type foo_t
        The virtual method cast cannot be hidden
 |}]

testsuite/tests/typing-misc/pr6416.ml

@@ -219,8 +219,8 @@ Error: Signature mismatch:
          class b : a
        does not match
          class b : a/2
-       The first class type has no method m
        The public method c cannot be hidden
+       The first class type has no method m
        Line 5, characters 4-74:
          Definition of class type a/1
        Line 2, characters 2-36:

testsuite/tests/typing-objects-bugs/pr3968_bad.compilers.reference

@@ -12,27 +12,19 @@ File "pr3968_bad.ml", lines 20-29, characters 0-3:
 Error: The class type
          object
            val l :
-             [ `Abs of
-                 string *
-                 ([> `App of
-                       [ `Abs of string * 'a | `App of expr * expr ] * exp ]
-                  as 'a)
-             | `App of expr * expr ]
+             [ `Abs of string * ([> `App of 'a * exp ] as 'b)
+             | `App of expr * expr ] as 'a
            val r : exp
-           method eval : (string, exp) Hashtbl.t -> 'a
+           method eval : (string, exp) Hashtbl.t -> 'b
          end
        is not matched by the class type exp
        The class type
          object
            val l :
-             [ `Abs of
-                 string *
-                 ([> `App of
-                       [ `Abs of string * 'a | `App of expr * expr ] * exp ]
-                  as 'a)
-             | `App of expr * expr ]
+             [ `Abs of string * ([> `App of 'a * exp ] as 'b)
+             | `App of expr * expr ] as 'a
            val r : exp
-           method eval : (string, exp) Hashtbl.t -> 'a
+           method eval : (string, exp) Hashtbl.t -> 'b
          end
        is not matched by the class type
          object method eval : (string, exp) Hashtbl.t -> expr end

testsuite/tests/typing-objects/Exemples.ml

@@ -286,12 +286,11 @@ class printable_color_point y c = object (self)
     Format.print_string ")"
 end;;
 [%%expect{|
-Line 3, characters 10-27:
+Line 3, characters 2-36:
 3 |   inherit printable_point y as super
-              ^^^^^^^^^^^^^^^^^
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Warning 13 [instance-variable-override]: the following instance variables are overridden by the class printable_point :
   x
-The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
 class printable_color_point :
   int ->
   string ->