add CamlinternalOO.inherits

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/fastclass@5938 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

3 files changed, 45 insertions, 25 deletions

diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 5841ae23a2..153c9f4357 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -226,11 +226,17 @@ let output_methods tbl vals methods lam =
   in
   transl_vals tbl true vals lam
 
+let rec ignore_cstrs cl =
+  match cl.cl_desc with
+    Tclass_constraint (cl, _, _, _) -> ignore_cstrs cl
+  | Tclass_apply (cl, _) -> ignore_cstrs cl
+  | _ -> cl
+
 let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
   match cl.cl_desc with
     Tclass_ident path ->
       begin match inh_init with
-        (obj_init, env_init, path)::inh_init ->
+        (obj_init, env_init, path')::inh_init ->
 	  let lpath = transl_path path in
           (inh_init,
            Llet (Strict, (if top then obj_init else env_init), 
@@ -305,30 +311,34 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
       let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
       (inh_init, transl_vals cla true vals cl_init)
   | Tclass_constraint (cl, vals, meths, concr_meths) ->
-      let core cl_init =
-        build_class_init cla pub_meths true inh_init cl_init msubst top cl
-      in
-      if cstr then
-        core cl_init
-      else
-        let virt_meths =
-          List.fold_right
-            (fun lab rem ->
-               if Concr.mem lab concr_meths then rem else lab::rem)
-            meths
-            []
-        in
-        let (inh_init, cl_init) =
-          core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]),
-                           cl_init))
-        in
-        (inh_init,
-         Lsequence(Lapply (oo_prim "narrow",
-                           [Lvar cla;
-                             transl_meth_list vals;
-                             transl_meth_list virt_meths;
-                             transl_meth_list (Concr.elements concr_meths)]),
-                   cl_init))
+      let virt_meths =
+        List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
+      let narrow_args =
+	[Lvar cla;
+         transl_meth_list vals;
+         transl_meth_list virt_meths;
+         transl_meth_list (Concr.elements concr_meths)] in
+      let cl = ignore_cstrs cl in
+      begin match cl.cl_desc, inh_init with
+	Tclass_ident path, (obj_init, env_init, path')::inh_init ->
+	  assert (Path.same path path');
+	  let lpath = transl_path path in
+          (inh_init,
+           Llet (Strict, (if top then obj_init else env_init), 
+		 Lapply(oo_prim "inherits", narrow_args @
+			[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
+                 cl_init))
+      | _ ->
+	  let core cl_init =
+            build_class_init cla pub_meths true inh_init cl_init msubst top cl
+	  in
+	  if cstr then core cl_init else
+          let (inh_init, cl_init) =
+            core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
+          in
+          (inh_init,
+           Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
+      end
 
 
 (*
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 248f1bc95b..dc357b1c49 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -412,6 +412,13 @@ let init_class table =
     compact_buckets table.buckets;
   table.initializers <- List.rev table.initializers
 
+let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
+  narrow cla vals virt_meths concr_meths;
+  let init =
+    if top then super cla env else Obj.repr (super cla) in
+  widen cla;
+  init
+
 (**** Objects ****)
 
 let create_object table =
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index dddc882907..3c1f52d7f8 100644
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -41,6 +41,9 @@ val add_initializer : table -> (obj -> unit) -> unit
 val dummy_table : table
 val create_table : string array -> table
 val init_class : table -> unit
+val inherits :
+    table -> string array -> string array -> string array ->
+    (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t
 
 (** {6 Objects} *)