Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Tentative fix for MPR#7624 (#1327) 

* Tentative fix for MPR#7624.

* Move the warning scope to the computation of pat_slot_list (because of delayed checks).

* Fix computation of `warn_unused` (using binding attributes) and add tests.

* Test enabling binding-level warning when they are globally disabled.

* Rename `warn_unused` to `warn_about_unused_bindings` for better readablity.
master
Xavier Clerc 2017-09-13 22:50:42 +01:00 committed by Alain Frisch
parent 588c23117b
commit 94b7ab801e
6 changed files with 133 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Changes
View File

@ -209,6 +209,9 @@ Working version
of ocamlc and a run of ocamlopt.
(Xavier Leroy, from a suggestion by Gerd Stolpmann)
- MPR#7624: handle warning attributes placed on let bindings
(Xavier Clerc, report by dinosaure, review by Alain Frisch)
### Other libraries:

1
testsuite/tests/warnings/Makefile
View File

@ -19,6 +19,7 @@ FLAGS=-w A
run-all:
@$(OCAMLC) $(FLAGS) -c deprecated_module.mli
@$(OCAMLC) $(FLAGS) -c module_without_cmx.mli
@$(OCAMLC) $(FLAGS) -c w32.mli
@$(OCAMLC) $(FLAGS) -c w60.mli
@for file in *.ml; do \
printf " ... testing '$$file':"; \

47
testsuite/tests/warnings/w32.ml Normal file
View File

@ -0,0 +1,47 @@
(* from MPR#7624 *)
let[@warning "-32"] f x = x
let g x = x
let h x = x
(* multiple bindings *)
let[@warning "-32"] i x = x
and j x = x
let k x = x
and[@warning "-32"] l x = x
let[@warning "-32"] m x = x
and n x = x
let o x = x
and[@warning "-32"] p x = x
(* recursive bindings *)
let[@warning "-32"] rec q x = x
and r x = x
let[@warning "-32"] rec s x = x
and[@warning "-39"] t x = x
let[@warning "-39"] rec u x = x
and v x = v x
(* disabled then re-enabled warnings *)
module M = struct
[@@@warning "-32"]
let f x = x
let[@warning "+32"] g x = x
let[@warning "+32"] h x = x
and i x = x
let j x = x
and[@warning "+32"] k x = x
end

9
testsuite/tests/warnings/w32.mli Normal file
View File

@ -0,0 +1,9 @@
(* from MPR#7624 *)
val g : 'a -> 'a
(* multiple bindings *)
val n : 'a -> 'a
val o : 'a -> 'a

26
testsuite/tests/warnings/w32.reference Normal file
View File

@ -0,0 +1,26 @@
File "w32.ml", line 27, characters 24-25:
Warning 39: unused rec flag.
File "w32.ml", line 30, characters 24-25:
Warning 39: unused rec flag.
File "w32.ml", line 7, characters 4-5:
Warning 32: unused value h.
File "w32.ml", line 13, characters 4-5:
Warning 32: unused value j.
File "w32.ml", line 15, characters 4-5:
Warning 32: unused value k.
File "w32.ml", line 28, characters 4-5:
Warning 32: unused value r.
File "w32.ml", line 31, characters 20-21:
Warning 32: unused value t.
File "w32.ml", line 33, characters 24-25:
Warning 32: unused value u.
File "w32.ml", line 34, characters 4-5:
Warning 32: unused value v.
File "w32.ml", line 42, characters 22-23:
Warning 32: unused value g.
File "w32.ml", line 43, characters 22-23:
Warning 32: unused value h.
File "w32.ml", line 46, characters 22-23:
Warning 32: unused value k.
File "w32.ml", line 39, characters 0-174:
Warning 60: unused module M.

87
typing/typecore.ml
View File

@ -4018,6 +4018,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
let nvs = List.map (fun _ -> newvar ()) spatl in
let (pat_list, new_env, force, unpacks) =
type_pattern_list env spatl scope nvs allow in
let attrs_list = List.map fst spatl in
let is_recursive = (rec_flag = Recursive) in
(* If recursive, first unify with an approximation of the expression *)
if is_recursive then
@ -4056,9 +4057,13 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
let current_slot = ref None in
let rec_needed = ref false in
let warn_unused =
Warnings.is_active (check "") || Warnings.is_active (check_strict "") ||
(is_recursive && (Warnings.is_active Warnings.Unused_rec_flag))
let warn_about_unused_bindings =
List.exists
(fun attrs ->
Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
Warnings.is_active (check "") || Warnings.is_active (check_strict "") ||
(is_recursive && (Warnings.is_active Warnings.Unused_rec_flag))))
attrs_list
in
let pat_slot_list =
(* Algorithm to detect unused declarations in recursive bindings:
@ -4077,43 +4082,45 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
are unused. If this is the case, for local declarations, the issued
warning is 26, not 27.
*)
List.map
(fun pat ->
if not warn_unused then pat, None
else
let some_used = ref false in
(* has one of the identifier of this pattern been used? *)
let slot = ref [] in
List.iter
(fun id ->
let vd = Env.find_value (Path.Pident id) new_env in
(* note: Env.find_value does not trigger the value_used event *)
let name = Ident.name id in
let used = ref false in
if not (name = "" || name.[0] = '_' || name.[0] = '#') then
add_delayed_check
(fun () ->
if not !used then
Location.prerr_warning vd.Types.val_loc
((if !some_used then check_strict else check) name)
);
Env.set_value_used_callback
name vd
(fun () ->
match !current_slot with
| Some slot ->
slot := (name, vd) :: !slot; rec_needed := true
| None ->
List.iter
(fun (name, vd) -> Env.mark_value_used env name vd)
(get_ref slot);
used := true;
some_used := true
)
)
(Typedtree.pat_bound_idents pat);
pat, Some slot
)
List.map2
(fun attrs pat ->
Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
if not warn_about_unused_bindings then pat, None
else
let some_used = ref false in
(* has one of the identifier of this pattern been used? *)
let slot = ref [] in
List.iter
(fun id ->
let vd = Env.find_value (Path.Pident id) new_env in
(* note: Env.find_value does not trigger the value_used event *)
let name = Ident.name id in
let used = ref false in
if not (name = "" || name.[0] = '_' || name.[0] = '#') then
add_delayed_check
(fun () ->
if not !used then
Location.prerr_warning vd.Types.val_loc
((if !some_used then check_strict else check) name)
);
Env.set_value_used_callback
name vd
(fun () ->
match !current_slot with
| Some slot ->
slot := (name, vd) :: !slot; rec_needed := true
| None ->
List.iter
(fun (name, vd) -> Env.mark_value_used env name vd)
(get_ref slot);
used := true;
some_used := true
)
)
(Typedtree.pat_bound_idents pat);
pat, Some slot
))
attrs_list
pat_list
in
let exp_list =