diff options
| -rw-r--r-- | .depend | 25 | ||||
| -rw-r--r-- | testsuite/tests/typing-warnings/records.ml.principal.reference | 72 | ||||
| -rw-r--r-- | testsuite/tests/typing-warnings/records.ml.reference | 82 | ||||
| -rw-r--r-- | typing/typecore.ml | 12 | ||||
| -rw-r--r-- | utils/warnings.ml | 9 | ||||
| -rw-r--r-- | utils/warnings.mli | 1 |
6 files changed, 169 insertions, 32 deletions
@@ -106,7 +106,8 @@ typing/path.cmi : typing/ident.cmi typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi typing/primitive.cmi : typing/printtyp.cmi : typing/types.cmi typing/path.cmi \ - typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi + typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \ + typing/env.cmi typing/printtyped.cmi : typing/typedtree.cmi typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \ typing/annot.cmi @@ -136,9 +137,9 @@ typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/env.cmi parsing/asttypes.cmi typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \ - typing/btype.cmi + typing/ident.cmi typing/btype.cmi typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \ - typing/btype.cmi + typing/ident.cmx typing/btype.cmi typing/cmi_format.cmo : typing/types.cmi utils/misc.cmi parsing/location.cmi \ utils/config.cmi typing/cmi_format.cmi typing/cmi_format.cmx : typing/types.cmx utils/misc.cmx parsing/location.cmx \ @@ -237,16 +238,18 @@ typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \ typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi typing/primitive.cmo : utils/misc.cmi typing/primitive.cmi typing/primitive.cmx : utils/misc.cmx typing/primitive.cmi -typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \ +typing/printtyp.cmo : typing/types.cmi utils/tbl.cmi typing/primitive.cmi \ typing/predef.cmi typing/path.cmi typing/outcometree.cmi \ - typing/oprint.cmi utils/misc.cmi parsing/longident.cmi typing/ident.cmi \ - typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \ - parsing/asttypes.cmi typing/printtyp.cmi -typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \ + typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/printtyp.cmi +typing/printtyp.cmx : typing/types.cmx utils/tbl.cmx typing/primitive.cmx \ typing/predef.cmx typing/path.cmx typing/outcometree.cmi \ - typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \ - typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \ - parsing/asttypes.cmi typing/printtyp.cmi + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/printtyp.cmi typing/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ parsing/asttypes.cmi typing/printtyped.cmi diff --git a/testsuite/tests/typing-warnings/records.ml.principal.reference b/testsuite/tests/typing-warnings/records.ml.principal.reference index ecd3865cd..0f58467ac 100644 --- a/testsuite/tests/typing-warnings/records.ml.principal.reference +++ b/testsuite/tests/typing-warnings/records.ml.principal.reference @@ -1,10 +1,26 @@ # module M1 : sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end -# Characters 89-90: +# Characters 49-50: + let f1 (r:t) = r.x (* ok *) + ^ +Warning 42: this use of x required disambiguation. +Characters 89-90: let f2 r = ignore (r:t); r.x (* non principal *) ^ Warning 18: this type-based field disambiguation is not principal. +Characters 89-90: + let f2 r = ignore (r:t); r.x (* non principal *) + ^ +Warning 42: this use of x required disambiguation. +Characters 148-149: + match r with {x; y} -> y + y (* ok *) + ^ +Warning 42: this use of x required disambiguation. +Characters 151-152: + match r with {x; y} -> y + y (* ok *) + ^ +Warning 42: this use of y required disambiguation. Characters 81-103: let f2 r = ignore (r:t); r.x (* non principal *) ^^^^^^^^^^^^^^^^^^^^^^ @@ -34,15 +50,27 @@ Characters 85-91: Error: This pattern matches values of type M1.u but a pattern was expected which matches values of type M1.t # module M : sig type t = { x : int; } type u = { x : bool; } end -# val f : M.t -> int = <fun> +# Characters 18-21: + let f (r:M.t) = r.M.x;; (* ok *) + ^^^ +Warning 42: this use of x required disambiguation. +val f : M.t -> int = <fun> # Characters 18-19: let f (r:M.t) = r.x;; (* warning *) ^ Warning 40: x is used out of scope. +Characters 18-19: + let f (r:M.t) = r.x;; (* warning *) + ^ +Warning 42: this use of x required disambiguation. val f : M.t -> int = <fun> # module M : sig type t = { x : int; y : int; } end # module N : sig type u = { x : bool; y : bool; } end -# Characters 30-36: +# Characters 57-58: + let f (r:M.t) = r.x + ^ +Warning 42: this use of x required disambiguation. +Characters 30-36: open N ^^^^^^ Warning 33: unused open N. @@ -64,7 +92,11 @@ module OK : sig val f : M.t -> int end type u = { x : bool; y : int; z : char; } type t = { x : int; y : bool; } end -# Characters 36-41: +# Characters 37-38: + let f {x;z} = x,z + ^ +Warning 42: this use of x required disambiguation. +Characters 36-41: let f {x;z} = x,z ^^^^^ Warning 9: the following labels are not bound in this record pattern: @@ -77,7 +109,15 @@ module OK : sig val f : M.u -> bool * char end let r = {x=true;z='z'} ^^^^^^^^^^^^^^ Error: Some record fields are undefined: y -# module OK : +# Characters 90-91: + let r = {x=3; y=true} + ^ +Warning 42: this use of x required disambiguation. +Characters 95-96: + let r = {x=3; y=true} + ^ +Warning 42: this use of y required disambiguation. +module OK : sig type u = { x : int; y : bool; } type t = { x : bool; y : int; z : char; } @@ -118,7 +158,11 @@ Error: The record field NM.y belongs to the type NM.foo = M.foo type foo = { x : int; y : int; } type bar = { x : int; y : int; z : int; } end -# Characters 72-73: +# Characters 65-66: + let f r = ignore (r: foo); {r with x = 2; z = 3} + ^ +Warning 42: this use of x required disambiguation. +Characters 72-73: let f r = ignore (r: foo); {r with x = 2; z = 3} ^ Error: The record type M.foo has no field z @@ -128,11 +172,23 @@ Error: The record type M.foo has no field z type bar = M.bar = { x : int; y : int; z : int; } type other = { a : int; b : int; } end -# Characters 73-74: +# Characters 66-67: + let f r = ignore (r: foo); { r with x = 3; a = 4 } + ^ +Warning 42: this use of x required disambiguation. +Characters 73-74: let f r = ignore (r: foo); { r with x = 3; a = 4 } ^ Error: The record type M.foo has no field a -# Characters 67-68: +# Characters 39-40: + let r = {x=1; y=2} + ^ +Warning 42: this use of x required disambiguation. +Characters 44-45: + let r = {x=1; y=2} + ^ +Warning 42: this use of y required disambiguation. +Characters 67-68: let r: other = {x=1; y=2} ^ Error: The record type M.other has no field x diff --git a/testsuite/tests/typing-warnings/records.ml.reference b/testsuite/tests/typing-warnings/records.ml.reference index 1b39032ba..fdfc911f6 100644 --- a/testsuite/tests/typing-warnings/records.ml.reference +++ b/testsuite/tests/typing-warnings/records.ml.reference @@ -1,7 +1,23 @@ # module M1 : sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end -# Characters 81-103: +# Characters 49-50: + let f1 (r:t) = r.x (* ok *) + ^ +Warning 42: this use of x required disambiguation. +Characters 89-90: + let f2 r = ignore (r:t); r.x (* non principal *) + ^ +Warning 42: this use of x required disambiguation. +Characters 148-149: + match r with {x; y} -> y + y (* ok *) + ^ +Warning 42: this use of x required disambiguation. +Characters 151-152: + match r with {x; y} -> y + y (* ok *) + ^ +Warning 42: this use of y required disambiguation. +Characters 81-103: let f2 r = ignore (r:t); r.x (* non principal *) ^^^^^^^^^^^^^^^^^^^^^^ Warning 34: unused type u. @@ -20,7 +36,15 @@ Characters 65-66: ^ Error: This expression has type bool but an expression was expected of type int -# Characters 81-103: +# Characters 86-87: + {x; y} -> y + y + ^ +Warning 42: this use of x required disambiguation. +Characters 89-90: + {x; y} -> y + y + ^ +Warning 42: this use of y required disambiguation. +Characters 81-103: ... {x; y} -> y + y en.............................. Warning 34: unused type u. @@ -30,15 +54,27 @@ Characters 86-87: Warning 27: unused variable x. module F2 : sig val f : M1.t -> int end # module M : sig type t = { x : int; } type u = { x : bool; } end -# val f : M.t -> int = <fun> +# Characters 18-21: + let f (r:M.t) = r.M.x;; (* ok *) + ^^^ +Warning 42: this use of x required disambiguation. +val f : M.t -> int = <fun> # Characters 18-19: let f (r:M.t) = r.x;; (* warning *) ^ Warning 40: x is used out of scope. +Characters 18-19: + let f (r:M.t) = r.x;; (* warning *) + ^ +Warning 42: this use of x required disambiguation. val f : M.t -> int = <fun> # module M : sig type t = { x : int; y : int; } end # module N : sig type u = { x : bool; y : bool; } end -# Characters 30-36: +# Characters 57-58: + let f (r:M.t) = r.x + ^ +Warning 42: this use of x required disambiguation. +Characters 30-36: open N ^^^^^^ Warning 33: unused open N. @@ -60,7 +96,11 @@ module OK : sig val f : M.t -> int end type u = { x : bool; y : int; z : char; } type t = { x : int; y : bool; } end -# Characters 36-41: +# Characters 37-38: + let f {x;z} = x,z + ^ +Warning 42: this use of x required disambiguation. +Characters 36-41: let f {x;z} = x,z ^^^^^ Warning 9: the following labels are not bound in this record pattern: @@ -73,7 +113,15 @@ module OK : sig val f : M.u -> bool * char end let r = {x=true;z='z'} ^^^^^^^^^^^^^^ Error: Some record fields are undefined: y -# module OK : +# Characters 90-91: + let r = {x=3; y=true} + ^ +Warning 42: this use of x required disambiguation. +Characters 95-96: + let r = {x=3; y=true} + ^ +Warning 42: this use of y required disambiguation. +module OK : sig type u = { x : int; y : bool; } type t = { x : bool; y : int; z : char; } @@ -114,7 +162,11 @@ Error: The record field NM.y belongs to the type NM.foo = M.foo type foo = { x : int; y : int; } type bar = { x : int; y : int; z : int; } end -# Characters 72-73: +# Characters 65-66: + let f r = ignore (r: foo); {r with x = 2; z = 3} + ^ +Warning 42: this use of x required disambiguation. +Characters 72-73: let f r = ignore (r: foo); {r with x = 2; z = 3} ^ Error: The record type M.foo has no field z @@ -124,11 +176,23 @@ Error: The record type M.foo has no field z type bar = M.bar = { x : int; y : int; z : int; } type other = { a : int; b : int; } end -# Characters 73-74: +# Characters 66-67: + let f r = ignore (r: foo); { r with x = 3; a = 4 } + ^ +Warning 42: this use of x required disambiguation. +Characters 73-74: let f r = ignore (r: foo); { r with x = 3; a = 4 } ^ Error: The record type M.foo has no field a -# Characters 67-68: +# Characters 39-40: + let r = {x=1; y=2} + ^ +Warning 42: this use of x required disambiguation. +Characters 44-45: + let r = {x=1; y=2} + ^ +Warning 42: this use of y required disambiguation. +Characters 67-68: let r: other = {x=1; y=2} ^ Error: The record type M.other has no field x diff --git a/typing/typecore.ml b/typing/typecore.ml index f08248494..f13e71585 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -597,7 +597,8 @@ end) = struct let disambiguate ?(warn=Location.prerr_warning) ?(check_lk=fun _ _ -> ()) ?scope lid env opath lbls = - match opath with + let scope = match scope with None -> lbls | Some l -> l in + let lbl = match opath with None -> begin match lbls with [] -> unbound_name_error env lid @@ -609,7 +610,6 @@ end) = struct lbl end | Some(tpath0, tpath, pr) -> - let scope = match scope with None -> lbls | Some l -> l in let warn_pr () = let kind = if type_kind = "record" then "field" else "constructor" in warn lid.loc @@ -651,6 +651,14 @@ end) = struct in raise (Error (lid.loc, env, Name_type_mismatch (type_kind, lid.txt, tp, tpl))) + in + begin match scope with + (lab1,_)::_ when lab1 == lbl -> () + | _ -> + Location.prerr_warning lid.loc + (Warnings.Disambiguated_name(get_name lbl)) + end; + lbl end module Label = NameChoice (struct diff --git a/utils/warnings.ml b/utils/warnings.ml index dd6b784d4..bc24b8021 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -59,6 +59,7 @@ type t = | Unused_rec_flag (* 39 *) | Name_out_of_scope of string list * bool (* 40 *) | Ambiguous_name of string list * bool (* 41 *) + | Disambiguated_name of string (* 42 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -109,9 +110,10 @@ let number = function | Unused_rec_flag -> 39 | Name_out_of_scope _ -> 40 | Ambiguous_name _ -> 41 + | Disambiguated_name _ -> 42 ;; -let last_warning_number = 41 +let last_warning_number = 42 (* Must be the max number returned by the [number] function. *) let letter = function @@ -206,7 +208,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";; +let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42";; let defaults_warn_error = "-a";; let () = parse_options false defaults_w;; @@ -318,6 +320,8 @@ let message = function | Ambiguous_name (slist, true) -> "this record contains fields that are ambiguous: " ^ String.concat " " slist ^ "." + | Disambiguated_name s -> + "this use of " ^ s ^ " required disambiguation." ;; let nerrors = ref 0;; @@ -405,6 +409,7 @@ let descriptions = 39, "Unused rec flag."; 40, "Constructor or label name used out of scope."; 41, "Ambiguous constructor or label name."; + 42, "Disambiguated name."; ] ;; diff --git a/utils/warnings.mli b/utils/warnings.mli index cc6426d17..bc994177a 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -54,6 +54,7 @@ type t = | Unused_rec_flag (* 39 *) | Name_out_of_scope of string list * bool (* 40 *) | Ambiguous_name of string list * bool (* 41 *) + | Disambiguated_name of string (* 42 *) ;; val parse_options : bool -> string -> unit;; |