check virtuals

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

3 files changed, 26 insertions, 22 deletions

diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index d53895099e..9d67a032a7 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -95,8 +95,7 @@ let rec generalize_class_type =
       generalize_class_type cty
 
 (* Return the virtual methods of a class type *)
-let virtual_methods cty =
-  let sign = Ctype.signature_of_class_type cty in
+let virtual_methods sign =
   let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
   List.fold_left
     (fun virt (lab, _, _) ->
@@ -1041,7 +1040,7 @@ let class_infos define_class kind
   in
 
   if cl.pci_virt = Concrete then begin
-    match virtual_methods typ with
+    match virtual_methods (Ctype.signature_of_class_type typ) with
       []   -> ()
     | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
   end;
@@ -1244,10 +1243,22 @@ let class_type_declarations env cls =
      decl,
    env)
 
+let type_object env loc s =
+  incr class_num;
+  let (desc, sign) = class_structure (string_of_int !class_num) env env s in
+  let sty = Ctype.expand_head env sign.cty_self in
+  begin match virtual_methods sign with
+    [] -> ()
+  | mets -> raise(Error(loc, Virtual_class(true, mets)))
+  end;
+  Ctype.hide_private_methods sty;
+  Ctype.close_object sty;
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  let meths = List.map (fun (s,_,_) -> s) fields in
+  (desc, sign, meths)
+
 let () =
-  Typecore.type_object :=
-    (fun env s ->
-      incr class_num; class_structure (string_of_int !class_num) env env s)
+  Typecore.type_object := type_object
 
 (*******************************)
 
@@ -1330,9 +1341,9 @@ let report_error ppf = function
   | Virtual_class (cl, mets) ->
       let print_mets ppf mets =
         List.iter (function met -> fprintf ppf "@ %s" met) mets in
-      let cl_mark = if cl then " type" else "" in
+      let cl_mark = if cl then "" else " type" in
       fprintf ppf
-        "@[This class %s should be virtual@ \
+        "@[This class%s should be virtual@ \
            @[<2>The following methods are undefined :%a@]
          @]"
         cl_mark print_mets mets
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 150a806b96..737fea20df 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -70,7 +70,8 @@ let type_module =
 (* Forward declaration, to be filled in by Typeclass.class_structure *)
 let type_object =
   ref (fun env s -> assert false :
-       Env.t -> Parsetree.class_structure -> class_structure * class_signature)
+       Env.t -> Location.t -> Parsetree.class_structure ->
+	 class_structure * class_signature * string list)
 
 (*
   Saving and outputting type information.
@@ -1323,19 +1324,11 @@ let rec type_exp env sexp =
          exp_env = env;
        }
   | Pexp_object s ->
-      let desc, ({cty_self = sty} as cty) = !type_object env s in
-      hide_private_methods sty;
-      close_object sty;
-      let meths =
-        List.fold_right
-          (fun (s,k,_) l ->
-            if field_kind_repr k = Fpresent then s :: l else l)
-          (fst (flatten_fields (object_fields sty))) []
-      in
+      let desc, sign, meths = !type_object env sexp.pexp_loc s in
       re {
-        exp_desc = Texp_object (desc, cty, meths);
+        exp_desc = Texp_object (desc, sign, meths);
         exp_loc = sexp.pexp_loc;
-        exp_type = sty;
+        exp_type = sign.cty_self;
         exp_env = env;
       }
   | Pexp_poly _ ->
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 34c96b32e5..00482b82f9 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -104,5 +104,5 @@ val report_error: formatter -> error -> unit
 val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
 (* Forward declaration, to be filled in by Typeclass.class_structure *)
 val type_object:
-  (Env.t -> Parsetree.class_structure ->
-   Typedtree.class_structure * class_signature) ref
+  (Env.t -> Location.t -> Parsetree.class_structure ->
+   Typedtree.class_structure * class_signature * string list) ref