Classes recursives compilees correctement.

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

bytecomp/translclass.ml

@@ -98,7 +98,7 @@ let transl_val_hiding tbl cl_init =
                         [Lvar tbl; transl_label name]),
 		cl_init)
 
-let transl_class cl =
+let transl_class cl_id cl =
   let obj = Ident.create "obj" in
   let (field_init, anc_id) =
     List.fold_right (transl_field_obj obj) cl.cl_field (Lvar obj, [])
@@ -122,4 +122,7 @@ let transl_class cl =
                              [Lvar table; obj_init])))
                  cl.cl_field)
   in
-    Lapply (oo_prim "create_class", [cl_init])
+    Lapply (oo_prim "create_class", [Lvar cl_id; cl_init])
+
+let class_stub =
+  Lconst (Const_block (0, [const_unit; const_unit; const_unit]))

bytecomp/translclass.mli

@@ -14,4 +14,5 @@
 open Typedtree
 open Lambda
 
-val transl_class : class_def -> lambda;;
+val class_stub : lambda
+val transl_class : Ident.t -> class_def -> lambda;;

bytecomp/translmod.ml

@@ -141,9 +141,13 @@ and transl_structure fields cc = function
   | Tstr_class cl_list :: rem ->
       List.fold_right
       	(fun (id, cl) re ->
-	   Llet(Strict, id, transl_class cl, re))
+	   Llet(Strict, id, class_stub, re))
 	cl_list
-	(transl_structure ((List.map fst cl_list) @ fields) cc rem)
+        (List.fold_right
+           (fun (id, cl) re ->
+              Lsequence(transl_class id cl, re))
+           cl_list
+	 (transl_structure ((List.map fst cl_list) @ fields) cc rem))
 
 (* Compile an implementation *)
 
@@ -192,9 +196,13 @@ let transl_store_structure glob map prims str =
   | Tstr_class cl_list :: rem ->
       List.fold_right
       	(fun (id, cl) re ->
-	   Llet(Strict, id, transl_class cl, re))
+	   Llet(Strict, id, class_stub, re))
 	cl_list
-	(store_idents glob map (List.map fst cl_list) (transl_store rem))
+        (List.fold_right
+           (fun (id, cl) re ->
+	      Lsequence(transl_class id cl, re))
+	   cl_list
+	   (store_idents glob map (List.map fst cl_list) (transl_store rem)))
 
   and store_ident glob map id cont =
     try
@@ -310,10 +318,18 @@ let transl_toplevel_item = function
   | Tstr_open path ->
       lambda_unit
   | Tstr_class cl_list ->
+      let lam =
+        List.fold_right
+      	  (fun (id, cl) re ->
+	     Llet(Strict, id, class_stub, re))
+          cl_list
+          (make_sequence
+             (fun (id, cl) ->
+                Lsequence(Lprim(Psetglobal id, [Lvar id]), transl_class id cl))
+	     cl_list)
+      in
       List.iter (fun (id, cl) -> Ident.make_global id) cl_list;
-      make_sequence
-        (fun (id, cl) -> Lprim(Psetglobal id, [transl_class cl]))
-	cl_list
+      lam
 
 let transl_toplevel_definition str =
   reset_labels ();

stdlib/oo.ml

@@ -262,9 +262,9 @@ let put array label element =
 
 type t
 type class_info =
-  {obj_init: t -> t;
-   class_init: table -> unit;
-   table: table}
+  {mutable obj_init: t -> t;
+   mutable class_init: table -> unit;
+   mutable table: table}
 
 let set_initializer table init =
   match table.init with
@@ -363,19 +363,20 @@ let new_object table =
   obj.(0) <- (magic table.buckets : t);
   obj
 
-let create_class class_init =
+let create_class class_info class_init =
   let table = new_table () in
   class_init table;
   method_count := !method_count + List.length table.methods;
   if !compact_table then
     compact_buckets table.buckets;
   inst_var_count := !inst_var_count + table.size - 1;
-  { class_init = class_init; table = table;
-    obj_init =
+  class_info.class_init <- class_init;
+  class_info.table <- table;
+  class_info.obj_init <-
       (function x -> 
          let obj = Array.create table.size (magic () : t) in
          obj.(0) <- (magic table.buckets : t);
-         (magic (List.hd (List.hd table.init))) obj x) }
+         (magic (List.hd (List.hd table.init))) obj x)
 
 (**** Objects ****)
 

stdlib/oo.mli

@@ -37,7 +37,7 @@ val set_method: table -> label -> item -> unit
 val get_variable: table -> string -> int
 val hide_variable: table -> string -> unit
 val get_private_variable: table -> string -> int
-val create_class: (table -> unit) -> class_info
+val create_class: class_info -> (table -> unit) -> unit
 
 (* Objects *)
 type t