Replace error by warning for PR#5835

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

6 files changed, 20 insertions, 10 deletions

diff --git a/testsuite/tests/typing-misc/labels.ml.principal.reference b/testsuite/tests/typing-misc/labels.ml.principal.reference
index 4dd851f1f9..b76dcddc51 100644
--- a/testsuite/tests/typing-misc/labels.ml.principal.reference
+++ b/testsuite/tests/typing-misc/labels.ml.principal.reference
@@ -3,6 +3,6 @@
 # Characters 5-6:
   f ?x:0;;
        ^
-Error: The function applied to this argument has type x:int -> int
-This argument cannot be applied with label ?x
+Warning 43: the label x is not optional.
+- : int = 1
 # 
diff --git a/testsuite/tests/typing-misc/labels.ml.reference b/testsuite/tests/typing-misc/labels.ml.reference
index 4dd851f1f9..b76dcddc51 100644
--- a/testsuite/tests/typing-misc/labels.ml.reference
+++ b/testsuite/tests/typing-misc/labels.ml.reference
@@ -3,6 +3,6 @@
 # Characters 5-6:
   f ?x:0;;
        ^
-Error: The function applied to this argument has type x:int -> int
-This argument cannot be applied with label ?x
+Warning 43: the label x is not optional.
+- : int = 1
 # 
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index fee65fad66..b81f8de1fa 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -958,8 +958,11 @@ and class_expr cl_num val_env met_env scl =
                       Btype.extract_label name more_sargs
                     in (l', sarg0, sargs @ sargs1, sargs2)
                 in
+                if optional = Required && Btype.is_optional l' then
+                  Location.prerr_warning sarg0.pexp_loc
+                    (Warnings.Nonoptional_label l);
                 sargs, more_sargs,
-                if Btype.is_optional l' || not (Btype.is_optional l) then
+                if optional = Required || Btype.is_optional l' then
                   Some (type_argument val_env sarg0 ty ty)
                 else
                   let ty0 = extract_option_type val_env ty in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index f13e715852..6ff79925e0 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -2952,10 +2952,11 @@ and type_application env funct sargs =
                     (Warnings.Not_principal "commuting this argument");
                 (l', sarg0, sargs @ sargs1, sargs2)
             in
-            sargs, more_sargs,
             if optional = Required && is_optional l' then
-              raise(Error(sarg0.pexp_loc, env, Apply_wrong_label(l', ty_fun')))
-            else if optional = Required || is_optional l' then
+              Location.prerr_warning sarg0.pexp_loc
+                (Warnings.Nonoptional_label l);
+            sargs, more_sargs,
+            if optional = Required || is_optional l' then
               Some (fun () -> type_argument env sarg0 ty ty0)
             else begin
               may_warn sarg0.pexp_loc
diff --git a/utils/warnings.ml b/utils/warnings.ml
index bc24b8021e..caf93e34f6 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -60,6 +60,7 @@ type t =
   | Name_out_of_scope of string list * bool (* 40 *)
   | Ambiguous_name of string list * bool    (* 41 *)
   | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -111,9 +112,10 @@ let number = function
   | Name_out_of_scope _ -> 40
   | Ambiguous_name _ -> 41
   | Disambiguated_name _ -> 42
+  | Nonoptional_label _ -> 43
 ;;
 
-let last_warning_number = 42
+let last_warning_number = 43
 (* Must be the max number returned by the [number] function. *)
 
 let letter = function
@@ -322,6 +324,8 @@ let message = function
       ^ String.concat " " slist ^ "."
   | Disambiguated_name s ->
       "this use of " ^ s ^ " required disambiguation."
+  | Nonoptional_label s ->
+      "the label " ^ s ^ " is not optional."
 ;;
 
 let nerrors = ref 0;;
@@ -409,7 +413,8 @@ let descriptions =
    39, "Unused rec flag.";
    40, "Constructor or label name used out of scope.";
    41, "Ambiguous constructor or label name.";
-   42, "Disambiguated name.";
+   42, "Disambiguated constructor or label name.";
+   43, "Nonoptional label applied as optional.";
   ]
 ;;
 
diff --git a/utils/warnings.mli b/utils/warnings.mli
index bc994177ae..9a5d9abd6e 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -55,6 +55,7 @@ type t =
   | Name_out_of_scope of string list * bool (* 40 *)
   | Ambiguous_name of string list * bool    (* 41 *)
   | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
 ;;
 
 val parse_options : bool -> string -> unit;;