diff options
| -rw-r--r-- | man/ocamlc.m | 2 | ||||
| -rw-r--r-- | testsuite/tests/typing-warnings/records.ml | 20 | ||||
| -rw-r--r-- | testsuite/tests/typing-warnings/records.ml.principal.reference | 29 | ||||
| -rw-r--r-- | testsuite/tests/typing-warnings/records.ml.reference | 29 | ||||
| -rw-r--r-- | typing/env.ml | 9 | ||||
| -rw-r--r-- | utils/warnings.ml | 12 | ||||
| -rw-r--r-- | utils/warnings.mli | 1 |
7 files changed, 97 insertions, 5 deletions
diff --git a/man/ocamlc.m b/man/ocamlc.m index c5c8c435b..d675b8d29 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -752,7 +752,7 @@ mentioned here corresponds to the empty set. .IP The default setting is -.BR \-w\ +a\-4\-6\-9\-27\-29\-32..39\-42\-44 . +.BR \-w\ +a\-4\-6\-9\-27\-29\-32..39\-42\-44-45 . Note that warnings .BR 5 \ and \ 10 are not always triggered, depending on the internals of the type checker. diff --git a/testsuite/tests/typing-warnings/records.ml b/testsuite/tests/typing-warnings/records.ml index 61a33c863..61a21cebb 100644 --- a/testsuite/tests/typing-warnings/records.ml +++ b/testsuite/tests/typing-warnings/records.ml @@ -138,3 +138,23 @@ class g = f A;; (* ok *) class f (_ : 'a) (_ : 'a) = object end;; class g = f (A : t) A;; (* warn with -principal *) + + +(* PR#5980 *) + +module Shadow1 = struct + type t = {x: int} + module M = struct + type s = {x: string} + end + open M (* this open is unused, it isn't reported as shadowing 'x' *) + let y : t = {x = 0} +end;; +module Shadow2 = struct + type t = {x: int} + module M = struct + type s = {x: string} + end + open M (* this open shadows label 'x' *) + let y = {x = ""} +end;; diff --git a/testsuite/tests/typing-warnings/records.ml.principal.reference b/testsuite/tests/typing-warnings/records.ml.principal.reference index 7a7745a90..7c66a0ab0 100644 --- a/testsuite/tests/typing-warnings/records.ml.principal.reference +++ b/testsuite/tests/typing-warnings/records.ml.principal.reference @@ -247,4 +247,33 @@ Characters 20-21: ^ Warning 42: this use of A required disambiguation. class g : f +# Characters 199-200: + let y : t = {x = 0} + ^ +Warning 42: this use of x required disambiguation. +Characters 114-120: + open M (* this open is unused, it isn't reported as shadowing 'x' *) + ^^^^^^ +Warning 33: unused open M. +module Shadow1 : + sig + type t = { x : int; } + module M : sig type s = { x : string; } end + val y : t + end +# Characters 97-103: + open M (* this open shadows label 'x' *) + ^^^^^^ +Warning 45: this open statement shadows the label x (which is later used) +Characters 149-157: + let y = {x = ""} + ^^^^^^^^ +Warning 41: these field labels belong to several types: M.s t +The first one was selected. Please disambiguate if this is wrong. +module Shadow2 : + sig + type t = { x : int; } + module M : sig type s = { x : string; } end + val y : M.s + end # diff --git a/testsuite/tests/typing-warnings/records.ml.reference b/testsuite/tests/typing-warnings/records.ml.reference index c88439c64..2952abd6b 100644 --- a/testsuite/tests/typing-warnings/records.ml.reference +++ b/testsuite/tests/typing-warnings/records.ml.reference @@ -246,4 +246,33 @@ Characters 20-21: ^ Warning 42: this use of A required disambiguation. class g : f +# Characters 199-200: + let y : t = {x = 0} + ^ +Warning 42: this use of x required disambiguation. +Characters 114-120: + open M (* this open is unused, it isn't reported as shadowing 'x' *) + ^^^^^^ +Warning 33: unused open M. +module Shadow1 : + sig + type t = { x : int; } + module M : sig type s = { x : string; } end + val y : t + end +# Characters 97-103: + open M (* this open shadows label 'x' *) + ^^^^^^ +Warning 45: this open statement shadows the label x (which is later used) +Characters 149-157: + let y = {x = ""} + ^^^^^^^^ +Warning 41: these field labels belong to several types: M.s t +The first one was selected. Please disambiguate if this is wrong. +module Shadow2 : + sig + type t = { x : int; } + module M : sig type s = { x : string; } end + val y : M.s + end # diff --git a/typing/env.ml b/typing/env.ml index 5a817fa3b..2f0bc6b92 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1368,7 +1368,7 @@ let open_pers_signature name env = open_signature None (Pident(Ident.create_persistent name)) ps.ps_sig env let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env = - if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost && (Warnings.is_active (Warnings.Unused_open "") || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))) + if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost && (Warnings.is_active (Warnings.Unused_open "") || Warnings.is_active (Warnings.Open_shadow_identifier ("", "")) || Warnings.is_active (Warnings.Open_shadow_label_constructor ("", ""))) then begin let used = ref false in !add_delayed_check_forward @@ -1380,7 +1380,12 @@ let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env = let slot kind s b = if b && not (List.mem (kind, s) !shadowed) then begin shadowed := (kind, s) :: !shadowed; - Location.prerr_warning loc (Warnings.Open_shadow_identifier (kind, s)); + let w = + match kind with + | "label" | "constructor" -> Warnings.Open_shadow_label_constructor (kind, s) + | _ -> Warnings.Open_shadow_identifier (kind, s) + in + Location.prerr_warning loc w end; used := true in diff --git a/utils/warnings.ml b/utils/warnings.ml index df4cdc94b..caef1fcda 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -62,6 +62,7 @@ type t = | Disambiguated_name of string (* 42 *) | Nonoptional_label of string (* 43 *) | Open_shadow_identifier of string * string (* 44 *) + | Open_shadow_label_constructor of string * string (* 45 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -115,9 +116,11 @@ let number = function | Disambiguated_name _ -> 42 | Nonoptional_label _ -> 43 | Open_shadow_identifier _ -> 44 + | Open_shadow_label_constructor _ -> 45 + ;; -let last_warning_number = 44 +let last_warning_number = 45 (* Must be the max number returned by the [number] function. *) let letter = function @@ -212,7 +215,7 @@ let parse_opt flags s = let parse_options errflag s = parse_opt (if errflag then error else active) s;; (* If you change these, don't forget to change them in man/ocamlc.m *) -let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44";; +let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45";; let defaults_warn_error = "-a";; let () = parse_options false defaults_w;; @@ -338,6 +341,10 @@ let message = function Printf.sprintf "this open statement shadows the %s identifier %s (which is later used)" kind s + | Open_shadow_label_constructor (kind, s) -> + Printf.sprintf + "this open statement shadows the %s %s (which is later used)" + kind s ;; let nerrors = ref 0;; @@ -428,6 +435,7 @@ let descriptions = 42, "Disambiguated constructor or label name."; 43, "Nonoptional label applied as optional."; 44, "Open statement shadows an already defined identifier."; + 45, "Open statement shadows an already defined label or constructor."; ] ;; diff --git a/utils/warnings.mli b/utils/warnings.mli index 9843195fa..c8a75d951 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -57,6 +57,7 @@ type t = | Disambiguated_name of string (* 42 *) | Nonoptional_label of string (* 43 *) | Open_shadow_identifier of string * string (* 44 *) + | Open_shadow_label_constructor of string * string (* 45 *) ;; val parse_options : bool -> string -> unit;; |