From 1f5882e53d452f3ec00d2278f8bd970c15ce6b23 Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Tue, 19 Feb 2013 03:12:36 +0000 Subject: Replace error by warning for PR#5835 git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13298 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- testsuite/tests/typing-misc/labels.ml.principal.reference | 4 ++-- testsuite/tests/typing-misc/labels.ml.reference | 4 ++-- typing/typeclass.ml | 5 ++++- typing/typecore.ml | 7 ++++--- utils/warnings.ml | 9 +++++++-- utils/warnings.mli | 1 + 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;; -- cgit v1.2.1