Equivalent de type_expect pour les methodes.

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

3 files changed, 45 insertions, 13 deletions

diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index f2aec7449e..de0ce5ae14 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -364,13 +364,17 @@ let type_class_field env var_env self cl (met_env, fields, vars_sig) =
       (met_env, fields, vars_sig)
 
   | Pcf_meth (lab, expr, loc)  ->
-      let (texp, ty) = type_method met_env self cl.pcl_self expr in
-      let ty' = Ctype.filter_method met_env lab self in
-        begin try Ctype.unify met_env ty ty' with Ctype.Unify trace ->
-          raise(Error(loc, Method_type_mismatch (lab, trace)))
-        end;
+      let ty = Ctype.filter_method met_env lab self in
+      let texp = type_method met_env self cl.pcl_self expr ty in
       (met_env, Cf_meth (lab, texp)::fields, vars_sig)
   
+(*       let (texp, ty) = type_method met_env self cl.pcl_self expr in *)
+(*       let ty' = Ctype.filter_method met_env lab self in *)
+(*         begin try Ctype.unify met_env ty ty' with Ctype.Unify trace -> *)
+(*           raise(Error(loc, Method_type_mismatch (lab, trace))) *)
+(*         end; *)
+(*       (met_env, Cf_meth (lab, texp)::fields, vars_sig) *)
+  
 let transl_class temp_env env
   (cl, id, cl_id, obj_id, self, concr, concr_meths, new_args, new_ty,
    temp_cl, temp_cl_params, cl_abbrev, temp_obj, temp_obj_params, abbrev)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 2e784fda00..a55cc48760 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -45,6 +45,7 @@ type error =
   | Outside_class
   | Value_multiply_overridden of string
   | Coercion_failure of type_expr * type_expr * (type_expr * type_expr) list
+  | Too_many_arguments
 
 exception Error of Location.t * error
 
@@ -721,7 +722,32 @@ let type_expression env sexp =
 
 (* Typing of methods *)
 
-let type_method env self self_name sexp =
+let rec type_expect_fun env sexp ty_expected =
+  match sexp.pexp_desc with
+    Pexp_function caselist ->
+      let (ty_arg, ty_res) =
+        try filter_arrow env ty_expected with Unify _ ->
+          raise(Error(sexp.pexp_loc, Too_many_arguments))
+      in
+      let cases =
+        List.map
+          (fun (spat, sexp) ->
+             let (pat, ext_env) = type_pattern env spat in
+             unify_pat env pat ty_arg;
+             let exp = type_expect_fun ext_env sexp ty_res in
+             (pat, exp))
+          caselist
+      in
+      Parmatch.check_unused cases;
+      Parmatch.check_partial sexp.pexp_loc cases;
+      { exp_desc = Texp_function cases;
+        exp_loc = sexp.pexp_loc;
+        exp_type = newty (Tarrow(ty_arg, ty_res));
+        exp_env = env }
+  | _ ->
+      type_expect env sexp ty_expected
+
+let type_method env self self_name sexp ty_expected =
   let (obj, env) =
     Env.enter_value "*self*" {val_type = self; val_kind = Val_reg} env
   in
@@ -743,12 +769,11 @@ let type_method env self self_name sexp =
 	   pat_type = self },
 	 env)
   in
-  let exp = type_exp env sexp in
-  ({ exp_desc = Texp_function [(pattern, exp)];
-     exp_loc = sexp.pexp_loc;
-     exp_type = newty (Tarrow(pattern.pat_type, exp.exp_type));
-     exp_env = env },
-   exp.exp_type)
+  let exp = type_expect_fun env sexp ty_expected in
+  { exp_desc = Texp_function [(pattern, exp)];
+    exp_loc = sexp.pexp_loc;
+    exp_type = newty (Tarrow(pattern.pat_type, exp.exp_type));
+    exp_env = env }
 
 (* Error report *)
 
@@ -852,3 +877,5 @@ let report_error = function
            print_string "it has type")
         (function () ->
            print_string "but is here used with type")
+  | Too_many_arguments ->
+      print_string "This function has too many arguments"
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 9fd98c3966..3dddcbbccb 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -24,7 +24,7 @@ val type_expression:
         Env.t -> Parsetree.expression -> Typedtree.expression
 val type_method:
         Env.t -> type_expr -> string option ->
-        Parsetree.expression -> Typedtree.expression * type_expr
+        Parsetree.expression -> type_expr -> Typedtree.expression
 val type_pattern_list:
         Env.t -> Parsetree.pattern list -> Typedtree.pattern list * Env.t
 val type_expect:
@@ -57,6 +57,7 @@ type error =
   | Outside_class
   | Value_multiply_overridden of string
   | Coercion_failure of type_expr * type_expr * (type_expr * type_expr) list
+  | Too_many_arguments
 
 exception Error of Location.t * error