Compilation correcte de "class c = let e in e'".

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

bytecomp/translclass.ml

@@ -21,6 +21,10 @@ open Translcore
 
 (* XXX Rajouter des evenements... *)
 
+type error = Illegal_class_expr
+
+exception Error of Location.t * error
+
 let lfunction params body =
   match body with
     Lfunction (Curried, params', body') ->
@@ -159,6 +163,19 @@ let rec build_object_init cl_table obj params inh_init cl =
   | Tclass_constraint (cl, vals, pub_meths, concr_meths) ->
       build_object_init cl_table obj params inh_init cl
 
+let rec build_object_init_0 cl_table params cl =
+  match cl.cl_desc with
+    Tclass_let (rec_flag, defs, vals, cl) ->
+      let (inh_init, obj_init) =
+        build_object_init_0 cl_table (vals @ params) cl
+      in
+      (inh_init, Translcore.transl_let rec_flag defs obj_init)
+  | _ ->
+      let obj = Ident.create "self" in
+      let (inh_init, obj_init) = build_object_init cl_table obj params [] cl in
+      let obj_init = lfunction [obj] obj_init in
+      (inh_init, obj_init)
+
 let bind_method tbl public_methods lab id cl_init =
   if List.mem lab public_methods then
     Llet(Alias, id, Lvar (meth lab), cl_init)
@@ -177,8 +194,7 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init cl =
         obj_init::inh_init ->
           (inh_init,
            Llet (Strict, obj_init, 
-                 Lapply(Lprim(Pfield 1, [transl_path path]),
-                        [Lvar cla]),
+                 Lapply(Lprim(Pfield 1, [transl_path path]), [Lvar cla]),
                  cl_init))
       | _ ->
           assert false
@@ -270,11 +286,11 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init cl =
    let ???) ?
 *)
 
-let transl_class cl_id arity pub_meths cl =
+let transl_class ids cl_id arity pub_meths cl =
   let cla = Ident.create "class" in
-  let obj = Ident.create "self" in
-  let (inh_init, obj_init) = build_object_init cla obj [] [] cl in
-  let obj_init = lfunction [obj] obj_init in
+  let (inh_init, obj_init) = build_object_init_0 cla [] cl in
+  if not (Translcore.check_recursive_lambda ids obj_init) then
+    raise(Error(cl.cl_loc, Illegal_class_expr));
   let (inh_init, cl_init) =
     build_class_init cla pub_meths true (List.rev inh_init) obj_init cl
   in
@@ -295,3 +311,12 @@ let transl_class cl_id arity pub_meths cl =
 
 let class_stub =
   Lprim(Pmakeblock(0, Mutable), [lambda_unit; lambda_unit; lambda_unit])
+
+(* Error report *)
+
+open Format
+
+let report_error = function
+  Illegal_class_expr ->
+    print_string
+      "This kind of class expression is not allowed"

bytecomp/translclass.mli

@@ -15,4 +15,11 @@ open Typedtree
 open Lambda
 
 val class_stub : lambda
-val transl_class : Ident.t -> int -> string list -> class_expr -> lambda;;
+val transl_class :
+  Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
+
+type error = Illegal_class_expr
+
+exception Error of Location.t * error
+
+val report_error: error -> unit

bytecomp/translcore.mli

@@ -28,6 +28,8 @@ val transl_primitive: Primitive.description -> lambda
 val transl_exception:
       Ident.t -> Path.t option -> exception_declaration -> lambda
 
+val check_recursive_lambda: Ident.t list -> lambda -> bool
+
 type error =
     Illegal_letrec_pat
   | Illegal_letrec_expr

bytecomp/translmod.ml

@@ -158,14 +158,12 @@ and transl_structure fields cc rootpath = function
   | Tstr_open path :: rem ->
       transl_structure fields cc rootpath rem
   | Tstr_class cl_list :: rem ->
+      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
       Lletrec(List.map
                 (fun (id, arity, meths, cl) ->
-                  (id, transl_class id arity meths cl))
+                  (id, transl_class ids id arity meths cl))
                 cl_list,
-              transl_structure
-                ((List.rev (List.map (fun (i, _, _, _) -> i) cl_list))
-                 @ fields)
-                cc rootpath rem)
+              transl_structure (List.rev ids @ fields) cc rootpath rem)
   | Tstr_cltype cl_list :: rem ->
       transl_structure fields cc rootpath rem
 
@@ -222,13 +220,12 @@ let transl_store_structure glob map prims str =
   | Tstr_open path :: rem ->
       transl_store rem
   | Tstr_class cl_list :: rem ->
+      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
       Lletrec(List.map
                 (fun (id, arity, meths, cl) ->
-                   (id, transl_class id arity meths cl))
+                   (id, transl_class ids id arity meths cl))
                 cl_list,
-              store_idents glob map (List.map (fun (i, _, _, _) -> i)
-                                       cl_list)
-                (transl_store rem))
+              store_idents glob map ids (transl_store rem))
   | Tstr_cltype cl_list :: rem ->
       transl_store rem
 
@@ -347,10 +344,11 @@ let transl_toplevel_item = function
   | Tstr_open path ->
       lambda_unit
   | Tstr_class cl_list ->
+      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
       let lam =
         Lletrec(List.map
                   (fun (id, arity, meths, cl) ->
-                     (id, transl_class id arity meths cl))
+                     (id, transl_class ids id arity meths cl))
                   cl_list,
                 make_sequence
                   (fun (id, _, _, _) -> Lprim(Psetglobal id, [Lvar id]))

driver/errors.ml

@@ -50,6 +50,8 @@ let report_error exn =
       print_string "I/O error: "; print_string msg
   | Typeclass.Error(loc, err) ->
       Location.print loc; Typeclass.report_error err
+  | Translclass.Error(loc, err) ->
+      Location.print loc; Translclass.report_error err
   | x ->
       close_box(); raise x
   end;