(**************************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) (* When you change this, you need to update: - the list 'description' at the bottom of this file - man/ocamlc.m *) type loc = { loc_start: Lexing.position; loc_end: Lexing.position; loc_ghost: bool; } type field_usage_warning = | Unused | Not_read | Not_mutated type constructor_usage_warning = | Unused | Not_constructed | Only_exported_private type type_declaration_usage_warning = | Declaration | Alias type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) (*| Deprecated --> alert "deprecated" *) (* 3 *) | Fragile_match of string (* 4 *) | Ignored_partial_application (* 5 *) | Labels_omitted of string list (* 6 *) | Method_override of string list (* 7 *) | Partial_match of Format_doc.t (* 8 *) | Missing_record_field_pattern of string (* 9 *) | Non_unit_statement (* 10 *) | Redundant_case (* 11 *) | Redundant_subpat (* 12 *) | Instance_variable_override of string list (* 13 *) | Illegal_backslash (* 14 *) | Implicit_public_methods of string list (* 15 *) | Unerasable_optional_argument (* 16 *) | Undeclared_virtual_method of string (* 17 *) | Not_principal of Format_doc.t (* 18 *) | Non_principal_labels of string (* 19 *) | Ignored_extra_argument (* 20 *) | Nonreturning_statement (* 21 *) | Preprocessor of string (* 22 *) | Useless_record_with (* 23 *) | Bad_module_name of string (* 24 *) | All_clauses_guarded (* 8, used to be 25 *) | Unused_var of string (* 26 *) | Unused_var_strict of string (* 27 *) | Wildcard_arg_to_constant_constr (* 28 *) | Eol_in_string (* 29 *) | Duplicate_definitions of string * string * string * string (*30 *) (* [Module_linked_twice of string * string * string] (* 31 *) was turned into a hard error *) | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) | Unused_type_declaration of string * type_declaration_usage_warning (* 34 *) | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) | Unused_constructor of string * constructor_usage_warning (* 37 *) | Unused_extension of string * bool * constructor_usage_warning (* 38 *) | Unused_rec_flag (* 39 *) | Name_out_of_scope of string * string list * bool (* 40 *) | Ambiguous_name of string list * string list * bool * string (* 41 *) | 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 *) | Bad_env_variable of string * string (* 46 *) | Attribute_payload of string * string (* 47 *) | Eliminated_optional_arguments of string list (* 48 *) | No_cmi_file of string * string option (* 49 *) | Unexpected_docstring of bool (* 50 *) | Wrong_tailcall_expectation of bool (* 51 *) | Fragile_literal_pattern (* 52 *) | Misplaced_attribute of string (* 53 *) | Duplicated_attribute of string (* 54 *) | Inlining_impossible of string (* 55 *) | Unreachable_case (* 56 *) | Ambiguous_var_in_pattern_guard of string list (* 57 *) | No_cmx_file of string (* 58 *) | Flambda_assignment_to_non_mutable_value (* 59 *) | Unused_module of string (* 60 *) | Unboxable_type_in_prim_decl of string (* 61 *) | Constraint_on_gadt (* 62 *) | Erroneous_printed_signature of string (* 63 *) | Unsafe_array_syntax_without_parsing (* 64 *) | Redefining_unit of string (* 65 *) | Unused_open_bang of string (* 66 *) | Unused_functor_parameter of string (* 67 *) | Match_on_mutable_state_prevent_uncurry (* 68 *) | Unused_field of string * field_usage_warning (* 69 *) | Missing_mli (* 70 *) | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) | Generative_application_expects_unit (* 73 *) | Degraded_to_partial_match (* 74 *) | Unnecessarily_partial_tuple_pattern (* 75 *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. If you add a new warning, add it at the end with a new number; do NOT reuse one of the holes. *) type alert = {kind:string; message:string; def:loc; use:loc} let number = function | Comment_start -> 1 | Comment_not_end -> 2 | Fragile_match _ -> 4 | Ignored_partial_application -> 5 | Labels_omitted _ -> 6 | Method_override _ -> 7 | Partial_match _ -> 8 | Missing_record_field_pattern _ -> 9 | Non_unit_statement -> 10 | Redundant_case -> 11 | Redundant_subpat -> 12 | Instance_variable_override _ -> 13 | Illegal_backslash -> 14 | Implicit_public_methods _ -> 15 | Unerasable_optional_argument -> 16 | Undeclared_virtual_method _ -> 17 | Not_principal _ -> 18 | Non_principal_labels _ -> 19 | Ignored_extra_argument -> 20 | Nonreturning_statement -> 21 | Preprocessor _ -> 22 | Useless_record_with -> 23 | Bad_module_name _ -> 24 | All_clauses_guarded -> 8 (* used to be 25 *) | Unused_var _ -> 26 | Unused_var_strict _ -> 27 | Wildcard_arg_to_constant_constr -> 28 | Eol_in_string -> 29 | Duplicate_definitions _ -> 30 | Unused_value_declaration _ -> 32 | Unused_open _ -> 33 | Unused_type_declaration _ -> 34 | Unused_for_index _ -> 35 | Unused_ancestor _ -> 36 | Unused_constructor _ -> 37 | Unused_extension _ -> 38 | Unused_rec_flag -> 39 | Name_out_of_scope _ -> 40 | Ambiguous_name _ -> 41 | Disambiguated_name _ -> 42 | Nonoptional_label _ -> 43 | Open_shadow_identifier _ -> 44 | Open_shadow_label_constructor _ -> 45 | Bad_env_variable _ -> 46 | Attribute_payload _ -> 47 | Eliminated_optional_arguments _ -> 48 | No_cmi_file _ -> 49 | Unexpected_docstring _ -> 50 | Wrong_tailcall_expectation _ -> 51 | Fragile_literal_pattern -> 52 | Misplaced_attribute _ -> 53 | Duplicated_attribute _ -> 54 | Inlining_impossible _ -> 55 | Unreachable_case -> 56 | Ambiguous_var_in_pattern_guard _ -> 57 | No_cmx_file _ -> 58 | Flambda_assignment_to_non_mutable_value -> 59 | Unused_module _ -> 60 | Unboxable_type_in_prim_decl _ -> 61 | Constraint_on_gadt -> 62 | Erroneous_printed_signature _ -> 63 | Unsafe_array_syntax_without_parsing -> 64 | Redefining_unit _ -> 65 | Unused_open_bang _ -> 66 | Unused_functor_parameter _ -> 67 | Match_on_mutable_state_prevent_uncurry -> 68 | Unused_field _ -> 69 | Missing_mli -> 70 | Unused_tmc_attribute -> 71 | Tmc_breaks_tailcall -> 72 | Generative_application_expects_unit -> 73 | Degraded_to_partial_match -> 74 | Unnecessarily_partial_tuple_pattern -> 75 ;; (* DO NOT REMOVE the ;; above: it is used by the testsuite/ests/warnings/mnemonics.mll test to determine where the definition of the number function above ends *) let last_warning_number = 75 type description = { number : int; names : string list; (* The first element of the list is the current name, any following ones are deprecated. The current name should always be derived mechanically from the constructor name. *) description : string; since : Sys.ocaml_release_info option; (* The compiler version introducing this warning; only tagged for warnings created after 3.12, which introduced the numbered syntax. *) } let since major minor = Some { Sys.major; minor; patchlevel=0; extra=None } let descriptions = [ { number = 1; names = ["comment-start"]; description = "Suspicious-looking start-of-comment mark."; since = None }; { number = 2; names = ["comment-not-end"]; description = "Suspicious-looking end-of-comment mark."; since = None }; { number = 3; names = []; description = "Deprecated synonym for the 'deprecated' alert."; since = None }; { number = 4; names = ["fragile-match"]; description = "Fragile pattern matching: matching that will remain complete even\n\ \ if additional constructors are added to one of the variant types\n\ \ matched."; since = None }; { number = 5; names = ["ignored-partial-application"]; description = "Partially applied function: expression whose result has function\n\ \ type and is ignored."; since = None }; { number = 6; names = ["labels-omitted"]; description = "Label omitted in function application."; since = None }; { number = 7; names = ["method-override"]; description = "Method overridden."; since = None }; { number = 8; names = ["partial-match"]; description = "Partial match: missing cases in pattern-matching."; since = None }; { number = 9; names = ["missing-record-field-pattern"]; description = "Missing fields in a record pattern."; since = None }; { number = 10; names = ["non-unit-statement"]; description = "Expression on the left-hand side of a sequence that doesn't have type\n\ \ \"unit\" (and that is not a function, see warning number 5)."; since = None }; { number = 11; names = ["redundant-case"]; description = "Redundant case in a pattern matching (unused match case)."; since = None }; { number = 12; names = ["redundant-subpat"]; description = "Redundant sub-pattern in a pattern-matching." ; since = None}; { number = 13; names = ["instance-variable-override"]; description = "Instance variable overridden."; since = None }; { number = 14; names = ["illegal-backslash"]; description = "Illegal backslash escape in a string constant."; since = None }; { number = 15; names = ["implicit-public-methods"]; description = "Private method made public implicitly."; since = None }; { number = 16; names = ["unerasable-optional-argument"]; description = "Unerasable optional argument."; since = None }; { number = 17; names = ["undeclared-virtual-method"]; description = "Undeclared virtual method."; since = None }; { number = 18; names = ["not-principal"]; description = "Non-principal type."; since = None }; { number = 19; names = ["non-principal-labels"]; description = "Type without principality."; since = None }; { number = 20; names = ["ignored-extra-argument"]; description = "Unused function argument."; since = None }; { number = 21; names = ["nonreturning-statement"]; description = "Non-returning statement."; since = None }; { number = 22; names = ["preprocessor"]; description = "Preprocessor warning."; since = None }; { number = 23; names = ["useless-record-with"]; description = "Useless record \"with\" clause."; since = None }; { number = 24; names = ["bad-module-name"]; description = "Bad module name: the source file name is not a valid OCaml module name."; since = None }; { number = 25; names = []; description = "Ignored: now part of warning 8."; since = None }; { number = 26; names = ["unused-var"]; description = "Suspicious unused variable: unused variable that is bound\n\ \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ \ character."; since = None }; { number = 27; names = ["unused-var-strict"]; description = "Innocuous unused variable: unused variable that is not bound with\n\ \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ \ character."; since = None }; { number = 28; names = ["wildcard-arg-to-constant-constr"]; description = "Wildcard pattern given as argument to a constant constructor."; since = None }; { number = 29; names = ["eol-in-string"]; description = "Unescaped end-of-line in a string constant (non-portable code)."; since = None }; { number = 30; names = ["duplicate-definitions"]; description = "Two labels or constructors of the same name are defined in two\n\ \ mutually recursive types."; since = None }; { number = 31; names = ["module-linked-twice"]; description = "A module is linked twice in the same executable.\n\ \ Ignored: now a hard error (since 5.1)."; since = None }; { number = 32; names = ["unused-value-declaration"]; description = "Unused value declaration."; since = since 4 0 }; { number = 33; names = ["unused-open"]; description = "Unused open statement."; since = since 4 0 }; { number = 34; names = ["unused-type-declaration"]; description = "Unused type declaration."; since = since 4 0 }; { number = 35; names = ["unused-for-index"]; description = "Unused for-loop index."; since = since 4 0 }; { number = 36; names = ["unused-ancestor"]; description = "Unused ancestor variable."; since = since 4 0 }; { number = 37; names = ["unused-constructor"]; description = "Unused constructor."; since = since 4 0 }; { number = 38; names = ["unused-extension"]; description = "Unused extension constructor."; since = since 4 0 }; { number = 39; names = ["unused-rec-flag"]; description = "Unused rec flag."; since = since 4 0 }; { number = 40; names = ["name-out-of-scope"]; description = "Constructor or label name used out of scope."; since = since 4 1 }; { number = 41; names = ["ambiguous-name"]; description = "Ambiguous constructor or label name."; since = since 4 1 }; { number = 42; names = ["disambiguated-name"]; description = "Disambiguated constructor or label name (compatibility warning)."; since = since 4 1 }; { number = 43; names = ["nonoptional-label"]; description = "Nonoptional label applied as optional."; since = since 4 1 }; { number = 44; names = ["open-shadow-identifier"]; description = "Open statement shadows an already defined identifier."; since = since 4 1 }; { number = 45; names = ["open-shadow-label-constructor"]; description = "Open statement shadows an already defined label or constructor."; since = since 4 1 }; { number = 46; names = ["bad-env-variable"]; description = "Error in environment variable."; since = since 4 1 }; { number = 47; names = ["attribute-payload"]; description = "Illegal attribute payload."; since = since 4 2 }; { number = 48; names = ["eliminated-optional-arguments"]; description = "Implicit elimination of optional arguments."; since = since 4 2 }; { number = 49; names = ["no-cmi-file"]; description = "Absent cmi file when looking up module alias."; since = since 4 2 }; { number = 50; names = ["unexpected-docstring"]; description = "Unexpected documentation comment."; since = since 4 3 }; { number = 51; names = ["wrong-tailcall-expectation"]; description = "Function call annotated with an incorrect @tailcall attribute."; since = since 4 3 }; { number = 52; names = ["fragile-literal-pattern"]; description = "Fragile constant pattern."; since = since 4 3 }; { number = 53; names = ["misplaced-attribute"]; description = "Attribute cannot appear in this context."; since = since 4 3 }; { number = 54; names = ["duplicated-attribute"]; description = "Attribute used more than once on an expression."; since = since 4 3 }; { number = 55; names = ["inlining-impossible"]; description = "Inlining impossible."; since = since 4 3 }; { number = 56; names = ["unreachable-case"]; description = "Unreachable case in a pattern-matching (based on type information)."; since = since 4 3 }; { number = 57; names = ["ambiguous-var-in-pattern-guard"]; description = "Ambiguous or-pattern variables under guard."; since = since 4 3 }; { number = 58; names = ["no-cmx-file"]; description = "Missing cmx file."; since = since 4 3 }; { number = 59; names = ["flambda-assignment-to-non-mutable-value"]; description = "Assignment to non-mutable value."; since = since 4 3 }; { number = 60; names = ["unused-module"]; description = "Unused module declaration."; since = since 4 4 }; { number = 61; names = ["unboxable-type-in-prim-decl"]; description = "Unboxable type in primitive declaration."; since = since 4 4 }; { number = 62; names = ["constraint-on-gadt"]; description = "Type constraint on GADT type declaration."; since = since 4 6 }; { number = 63; names = ["erroneous-printed-signature"]; description = "Erroneous printed signature."; since = since 4 8 }; { number = 64; names = ["unsafe-array-syntax-without-parsing"]; description = "-unsafe used with a preprocessor returning a syntax tree."; since = since 4 8 }; { number = 65; names = ["redefining-unit"]; description = "Type declaration defining a new '()' constructor."; since = since 4 8 }; { number = 66; names = ["unused-open-bang"]; description = "Unused open! statement."; since = since 4 8 }; { number = 67; names = ["unused-functor-parameter"]; description = "Unused functor parameter."; since = since 4 10 }; { number = 68; names = ["match-on-mutable-state-prevent-uncurry"]; description = "Pattern-matching depending on mutable state prevents the remaining \n\ \ arguments from being uncurried."; since = since 4 12 }; { number = 69; names = ["unused-field"]; description = "Unused record field."; since = since 4 13 }; { number = 70; names = ["missing-mli"]; description = "Missing interface file."; since = since 4 13 }; { number = 71; names = ["unused-tmc-attribute"]; description = "Unused @tail_mod_cons attribute."; since = since 4 14 }; { number = 72; names = ["tmc-breaks-tailcall"]; description = "A tail call is turned into a non-tail call \ by the @tail_mod_cons transformation."; since = since 4 14 }; { number = 73; names = ["generative-application-expects-unit"]; description = "A generative functor is applied to an empty structure \ (struct end) rather than to ()."; since = since 5 1 }; { number = 74; names = ["degraded-to-partial-match"]; description = "A pattern-matching is compiled as partial \ even if it appears to be total."; since = since 5 3 }; { number = 75; names = ["unnecessarily-partial-tuple-pattern"]; description = "A tuple pattern ends in .. but fully matches its expected \ type."; since = since 5 4 }; ] let name_to_number = let h = Hashtbl.create last_warning_number in List.iter (fun {number; names; _} -> List.iter (fun name -> Hashtbl.add h name number) names ) descriptions; fun s -> Hashtbl.find_opt h s (* Must be the max number returned by the [number] function. *) let letter = function | 'a' -> let rec loop i = if i = 0 then [] else i :: loop (i - 1) in loop last_warning_number | 'b' -> [] | 'c' -> [1; 2] | 'd' -> [3] | 'e' -> [4] | 'f' -> [5] | 'g' -> [] | 'h' -> [] | 'i' -> [] | 'j' -> [] | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39] | 'l' -> [6] | 'm' -> [7] | 'n' -> [] | 'o' -> [] | 'p' -> [8] | 'q' -> [] | 'r' -> [9] | 's' -> [10] | 't' -> [] | 'u' -> [11; 12] | 'v' -> [13] | 'w' -> [] | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30] | 'y' -> [26] | 'z' -> [27] | _ -> assert false type state = { active: bool array; error: bool array; alerts: (Misc.Stdlib.String.Set.t * bool); (* false:set complement *) alert_errors: (Misc.Stdlib.String.Set.t * bool); (* false:set complement *) } let current = ref { active = Array.make (last_warning_number + 1) true; error = Array.make (last_warning_number + 1) false; alerts = (Misc.Stdlib.String.Set.empty, false); alert_errors = (Misc.Stdlib.String.Set.empty, true); (* all soft *) } let disabled = ref false let without_warnings f = Misc.protect_refs [Misc.R(disabled, true)] f let backup () = !current let restore x = current := x let is_active x = not !disabled && (!current).active.(number x) let is_error x = not !disabled && (!current).error.(number x) let alert_is_active {kind; _} = not !disabled && let (set, pos) = (!current).alerts in Misc.Stdlib.String.Set.mem kind set = pos let alert_is_error {kind; _} = not !disabled && let (set, pos) = (!current).alert_errors in Misc.Stdlib.String.Set.mem kind set = pos let with_state state f = let prev = backup () in restore state; try let r = f () in restore prev; r with exn -> restore prev; raise exn let mk_lazy f = let state = backup () in lazy (with_state state f) let set_alert ~error ~enable s = let upd = match s with | "all" -> (Misc.Stdlib.String.Set.empty, not enable) | s -> let (set, pos) = if error then (!current).alert_errors else (!current).alerts in let f = if enable = pos then Misc.Stdlib.String.Set.add else Misc.Stdlib.String.Set.remove in (f s set, pos) in if error then current := {(!current) with alert_errors=upd} else current := {(!current) with alerts=upd} let parse_alert_option s = let n = String.length s in let id_char = function | 'a'..'z' | 'A'..'Z' | '_' | '\'' | '0'..'9' -> true | _ -> false in let rec parse_id i = if i < n && id_char s.[i] then parse_id (i + 1) else i in let rec scan i = if i = n then () else if i + 1 = n then raise (Arg.Bad "Ill-formed list of alert settings") else match s.[i], s.[i+1] with | '+', '+' -> id (set_alert ~error:true ~enable:true) (i + 2) | '+', _ -> id (set_alert ~error:false ~enable:true) (i + 1) | '-', '-' -> id (set_alert ~error:true ~enable:false) (i + 2) | '-', _ -> id (set_alert ~error:false ~enable:false) (i + 1) | '@', _ -> id (fun s -> set_alert ~error:true ~enable:true s; set_alert ~error:false ~enable:true s) (i + 1) | _ -> raise (Arg.Bad "Ill-formed list of alert settings") and id f i = let j = parse_id i in if j = i then raise (Arg.Bad "Ill-formed list of alert settings"); let id = String.sub s i (j - i) in f id; scan j in scan 0 type modifier = | Set (** +a *) | Clear (** -a *) | Set_all (** @a *) type token = | Letter of char * modifier option | Num of int * int * modifier let ghost_loc_in_file name = let pos = { Lexing.dummy_pos with pos_fname = name } in { loc_start = pos; loc_end = pos; loc_ghost = true } let letter_alert tokens = let print_warning_char ppf c = let lowercase = Char.lowercase_ascii c = c in Format.fprintf ppf "%c%c" (if lowercase then '-' else '+') c in let print_modifier ppf = function | Set_all -> Format.fprintf ppf "@" | Clear -> Format.fprintf ppf "-" | Set -> Format.fprintf ppf "+" in let print_token ppf = function | Num (a,b,m) -> if a = b then Format.fprintf ppf "%a%d" print_modifier m a else Format.fprintf ppf "%a%d..%d" print_modifier m a b | Letter(l,Some m) -> Format.fprintf ppf "%a%c" print_modifier m l | Letter(l,None) -> print_warning_char ppf l in let consecutive_letters = (* we are tracking sequences of 2 or more consecutive unsigned letters in warning strings, for instance in '-w "not-principa"'. *) let commit_chunk l = function | [] | [ _ ] -> l | _ :: _ :: _ as chunk -> List.rev chunk :: l in let group_consecutive_letters (l,current) = function | Letter (x, None) -> (l, x::current) | _ -> (commit_chunk l current, []) in let l, on_going = List.fold_left group_consecutive_letters ([],[]) tokens in commit_chunk l on_going in match consecutive_letters with | [] -> None | example :: _ -> let nowhere = ghost_loc_in_file "_none_" in let spelling_hint ppf = let max_seq_len = List.fold_left (fun l x -> Int.max l (List.length x)) 0 consecutive_letters in if max_seq_len >= 5 then Format.fprintf ppf "@ @[Hint: Did you make a spelling mistake \ when using a mnemonic name?@]" else () in let message = Format.asprintf "@[@[Setting a warning with a sequence of lowercase \ or uppercase letters,@ like '%a',@ is deprecated.@]@ \ @[Use the equivalent signed form:@ %t.@]@ \ @[Hint: Enabling or disabling a warning by its mnemonic name \ requires a + or - prefix.@]\ %t@?@]" Format.(pp_print_list ~pp_sep:(fun _ -> ignore) pp_print_char) example (fun ppf -> List.iter (print_token ppf) tokens) spelling_hint in Some { kind="ocaml_deprecated_cli"; use=nowhere; def=nowhere; message } let parse_warnings s = let error () = raise (Arg.Bad "Ill-formed list of warnings") in let rec get_num n i = if i >= String.length s then i, n else match s.[i] with | '0'..'9' -> get_num (10 * n + Char.code s.[i] - Char.code '0') (i + 1) | _ -> i, n in let get_range i = let i, n1 = get_num 0 i in if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then let i, n2 = get_num 0 (i + 2) in if n2 < n1 then error (); i, n1, n2 else i, n1, n1 in let rec loop tokens i = if i >= String.length s then List.rev tokens else match s.[i] with | 'A' .. 'Z' | 'a' .. 'z' -> loop (Letter(s.[i],None)::tokens) (i+1) | '+' -> loop_letter_num tokens Set (i+1) | '-' -> loop_letter_num tokens Clear (i+1) | '@' -> loop_letter_num tokens Set_all (i+1) | _ -> error () and loop_letter_num tokens modifier i = if i >= String.length s then error () else match s.[i] with | '0' .. '9' -> let i, n1, n2 = get_range i in loop (Num(n1,n2,modifier)::tokens) i | 'A' .. 'Z' | 'a' .. 'z' -> loop (Letter(s.[i],Some modifier)::tokens) (i+1) | _ -> error () in loop [] 0 let parse_opt error active errflag s = let flags = if errflag then error else active in let action modifier i = match modifier with | Set -> if i = 3 then set_alert ~error:errflag ~enable:true "deprecated" else flags.(i) <- true | Clear -> if i = 3 then set_alert ~error:errflag ~enable:false "deprecated" else flags.(i) <- false | Set_all -> if i = 3 then begin set_alert ~error:false ~enable:true "deprecated"; set_alert ~error:true ~enable:true "deprecated" end else begin active.(i) <- true; error.(i) <- true end in let eval = function | Letter(c, m) -> let lc = Char.lowercase_ascii c in let modifier = match m with | None -> if c = lc then Clear else Set | Some m -> m in List.iter (action modifier) (letter lc) | Num(n1,n2,modifier) -> for n = n1 to Int.min n2 last_warning_number do action modifier n done in let parse_and_eval s = let tokens = parse_warnings s in List.iter eval tokens; letter_alert tokens in match name_to_number s with | Some n -> action Set n; None | None -> if s = "" then parse_and_eval s else begin let rest = String.sub s 1 (String.length s - 1) in match s.[0], name_to_number rest with | '+', Some n -> action Set n; None | '-', Some n -> action Clear n; None | '@', Some n -> action Set_all n; None | _ -> parse_and_eval s end let parse_options errflag s = let error = Array.copy (!current).error in let active = Array.copy (!current).active in let alerts = parse_opt error active errflag s in current := {(!current) with error; active}; alerts (* If you change these, don't forget to change them in man/ocamlc.m *) let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70-74" let defaults_warn_error = "-a" let default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] let () = ignore @@ parse_options false defaults_w let () = ignore @@ parse_options true defaults_warn_error let () = List.iter (set_alert ~error:false ~enable:false) default_disabled_alerts module Fmt = Format_doc module Style = Misc.Style let msg = Fmt.doc_printf let comma_inline_list = Fmt.(pp_print_list ~pp_sep:comma Style.inline_code) let space_inline_list ppf l = let pp_sep = Fmt.pp_print_space in Fmt.fprintf ppf "@[%a@]" (Fmt.pp_print_list ~pp_sep Style.inline_code) l let expand ppf s = if s = "" then () else Fmt.fprintf ppf "@ %s" s let message = function | Comment_start -> msg "this %a is the start of a comment.@ \ %t: Did you forget spaces when writing the infix operator %a?" Style.inline_code "(*" Style.hint Style.inline_code "( * )" | Comment_not_end -> msg "this is not the end of a comment." | Fragile_match "" -> msg "this pattern-matching is fragile." | Fragile_match s -> msg "this pattern-matching is fragile.@ \ It will remain exhaustive when constructors are added to type %a." Style.inline_code s | Ignored_partial_application -> msg "this function application is partial,@ \ maybe@ some@ arguments@ are@ missing." | Labels_omitted [] -> assert false | Labels_omitted [l] -> msg "label %a@ was omitted@ in@ the@ application@ of@ this@ function." Style.inline_code l | Labels_omitted ls -> msg "labels %a@ were omitted@ in@ the@ application@ of@ this@ function." comma_inline_list ls | Method_override [lab] -> msg "the method %a is overridden." Style.inline_code lab | Method_override (cname :: slist) -> msg "the following methods are overridden@ by@ the@ class@ %a:@;<1 2>%a" Style.inline_code cname space_inline_list slist | Method_override [] -> assert false | Partial_match doc -> if doc = Format_doc.Doc.empty then msg "this pattern-matching is not exhaustive." else msg "this pattern-matching is not exhaustive.@ \ @[Here is an example of a case that is not matched:@;<1 2>%a@]" Format_doc.pp_doc doc | Missing_record_field_pattern s -> msg "the following labels are not bound@ in@ this@ \ record@ pattern:@;<1 2>%a.@ \ @[Either bind these labels explicitly or add %a to the pattern.@]" Style.inline_code s Style.inline_code "; _" | Non_unit_statement -> msg "this expression should have type unit." | Redundant_case -> msg "this match case is unused." | Redundant_subpat -> msg "this sub-pattern is unused." | Instance_variable_override [lab] -> msg "the instance variable %a is overridden." Style.inline_code lab | Instance_variable_override (cname :: slist) -> msg "the following instance variables@ are overridden@ \ by the class %a:@;<1 2>%a" Style.inline_code cname space_inline_list slist | Instance_variable_override [] -> assert false | Illegal_backslash -> msg "illegal backslash escape in string.@ \ %t: Single backslashes %a are reserved for escape sequences@ \ (%a, %a, ...).@ Did you check the list of OCaml escape sequences?@ \ To get a backslash character, escape it with a second backslash: %a." Style.hint Style.inline_code {|\|} Style.inline_code {|\n|} Style.inline_code {|\r|} Style.inline_code {|\\|} | Implicit_public_methods l -> msg "the following private methods@ were@ made@ public@ \ implicitly:@;<1 2>%a." space_inline_list l | Unerasable_optional_argument -> msg "this optional argument cannot be erased." | Undeclared_virtual_method m -> msg "the virtual method %a is not declared." Style.inline_code m | Not_principal emsg -> msg "%a@ is@ not@ principal." Fmt.pp_doc emsg | Non_principal_labels s -> msg "%s without principality." s | Ignored_extra_argument -> msg "this argument will not be used by the function." | Nonreturning_statement -> msg "this statement never returns (or has an unsound type.)" | Preprocessor s -> msg "%s" s | Useless_record_with -> msg "all the fields are explicitly listed in this record:@ \ the %a clause is useless." Style.inline_code "with" | Bad_module_name (modname) -> msg "bad source file name: %a is not a valid module name." Style.inline_code modname | All_clauses_guarded -> msg "this pattern-matching is not exhaustive.@ \ All clauses in this pattern-matching are guarded." | Unused_var v | Unused_var_strict v -> msg "unused variable %a." Style.inline_code v | Wildcard_arg_to_constant_constr -> msg "wildcard pattern given as argument to a constant constructor" | Eol_in_string -> msg "unescaped end-of-line in a string constant@ \ (non-portable behavior before OCaml 5.2)" | Duplicate_definitions (kind, cname, tc1, tc2) -> msg "the %s %a is defined in both types %a and %a." kind Style.inline_code cname Style.inline_code tc1 Style.inline_code tc2 | Unused_value_declaration v -> msg "unused value %a." Style.inline_code v | Unused_open s -> msg "unused open %a." Style.inline_code s | Unused_open_bang s -> msg "unused open! %a." Style.inline_code s | Unused_type_declaration (s, Declaration) -> msg "unused type %a." Style.inline_code s | Unused_type_declaration (s, Alias) -> msg "unused type alias %a." Style.inline_code s | Unused_for_index s -> msg "unused for-loop index %a." Style.inline_code s | Unused_ancestor s -> msg "unused ancestor variable %a." Style.inline_code s | Unused_constructor (s, Unused) -> msg "unused constructor %a." Style.inline_code s | Unused_constructor (s, Not_constructed) -> msg "constructor %a is never used to build values.@ \ (However, this constructor appears in patterns.)" Style.inline_code s | Unused_constructor (s, Only_exported_private) -> msg "constructor %a is never used to build values.@ \ Its type is exported as a private type." Style.inline_code s | Unused_extension (s, is_exception, complaint) -> let kind = if is_exception then "exception" else "extension constructor" in begin match complaint with | Unused -> msg "unused %s %a" kind Style.inline_code s | Not_constructed -> msg "%s %a is never used@ to@ build@ values.@ \ (However, this constructor appears in patterns.)" kind Style.inline_code s | Only_exported_private -> msg "%s %a is never used@ to@ build@ values.@ \ It is exported or rebound as a private extension." kind Style.inline_code s end | Unused_rec_flag -> msg "unused rec flag." | Name_out_of_scope (ty, [nm], false) -> msg "%a was selected from type %a.@ \ @[It is not visible in the current scope,@ and@ will@ not@ \ be@ selected@ if the type becomes unknown@]." Style.inline_code nm Style.inline_code ty | Name_out_of_scope (_, _, false) -> assert false | Name_out_of_scope (ty, slist, true) -> msg "this record of type %a@ contains@ fields@ that@ are@ \ not@ visible in the current scope:@;<1 2>%a.@ \ @[They will not be selected@ if the type@ becomes@ unknown.@]" Style.inline_code ty space_inline_list slist | Ambiguous_name ([s], tl, false, expansion) -> msg "%a belongs to several types:@;<1 2>%a.@ \ The first one was selected.@ \ @[Please disambiguate@ if@ this@ is wrong.%a@]" Style.inline_code s space_inline_list tl expand expansion | Ambiguous_name (_, _, false, _ ) -> assert false | Ambiguous_name (_slist, tl, true, expansion) -> msg "these field labels belong to several types:@;<1 2>%a.@ \ @[The first one was selected.@ \ Please disambiguate@ if@ this@ is@ wrong.%a@]" space_inline_list tl expand expansion | Disambiguated_name s -> msg "this use of %a@ relies@ on@ type-directed@ disambiguation,@ \ @[it@ will@ not@ compile@ with@ OCaml@ 4.00@ or@ earlier.@]" Style.inline_code s | Nonoptional_label s -> msg "the label %a is not optional." Style.inline_code s | Open_shadow_identifier (kind, s) -> msg "this open statement shadows@ the@ %s identifier@ %a@ \ (which is later used)" kind Style.inline_code s | Open_shadow_label_constructor (kind, s) -> msg "this open statement shadows@ the@ %s %a@ (which is later used)" kind Style.inline_code s | Bad_env_variable (var, s) -> msg "illegal environment variable %a : %s" Style.inline_code var s | Attribute_payload (a, s) -> msg "illegal payload for attribute %a.@ %s" Style.inline_code a s | Eliminated_optional_arguments sl -> msg "implicit elimination@ of optional argument%s@ %a" (if List.length sl = 1 then "" else "s") comma_inline_list sl | No_cmi_file(name, None) -> msg "no cmi file was found@ in path for module %a" Style.inline_code name | No_cmi_file(name, Some wmsg) -> msg "no valid cmi file was found@ in path for module %a.@ %s" Style.inline_code name wmsg | Unexpected_docstring unattached -> if unattached then msg "unattached documentation comment (ignored)" else msg "ambiguous documentation comment" | Wrong_tailcall_expectation b -> msg "expected %s" (if b then "tailcall" else "non-tailcall") | Fragile_literal_pattern -> let[@manual.ref "ss:warn52"] ref_manual = [ 13; 5; 3 ] in msg "Code should not depend@ on@ the@ actual@ values of@ \ this@ constructor's arguments.@ @[They are only for@ information@ \ and@ may@ change@ in@ future versions.@ %a@]" Misc.print_see_manual ref_manual | Unreachable_case -> msg "this match case is unreachable.@ \ Consider replacing it with a refutation case %a" Style.inline_code " -> ." | Misplaced_attribute attr_name -> msg "the %a attribute cannot appear in this context" Style.inline_code attr_name | Duplicated_attribute attr_name -> msg "the %a attribute is used more than once@ on@ this@ \ expression" Style.inline_code attr_name | Inlining_impossible reason -> msg "Cannot inline:@ %s" reason | Ambiguous_var_in_pattern_guard vars -> let[@manual.ref "ss:warn57"] ref_manual = [ 13; 5; 4 ] in let vars = List.sort String.compare vars in let vars_explanation = match vars with | [] -> assert false | [x] -> Fmt.dprintf "variable %a appears in@ different@ places@ in@ \ different@ or-pattern@ alternatives." Style.inline_code x | _::_ -> Fmt.dprintf "variables %a appears in@ different@ places@ in@ \ different@ or-pattern@ alternatives." comma_inline_list vars in msg "Ambiguous or-pattern variables under@ guard;@ \ %t@ \ @[Only the first match will be used to evaluate@ \ the@ guard@ expression.@ %a@]" vars_explanation Misc.print_see_manual ref_manual | No_cmx_file name -> msg "no cmx file was found@ in@ path@ for@ module@ %a,@ \ and@ its@ interface@ was@ not@ compiled@ with %a" Style.inline_code name Style.inline_code "-opaque" | Flambda_assignment_to_non_mutable_value -> msg "A potential@ assignment@ to@ a@ non-mutable@ value@ was@ detected@ \ in@ this@ source@ file.@ \ Such@ assignments@ may@ generate@ incorrect@ code@ \ when@ using@ Flambda." | Unused_module s -> msg "unused module %a." Style.inline_code s | Unboxable_type_in_prim_decl t -> msg "This primitive declaration uses type %a,@ whose@ representation@ \ may be either boxed or unboxed.@ Without@ an@ annotation@ to@ \ indicate@ which@ representation@ is@ intended,@ the@ boxed@ \ representation@ has@ been@ selected@ by@ default.@ This@ default@ \ choice@ may@ change@ in@ future@ versions@ of@ the@ compiler,@ \ breaking@ the@ primitive@ implementation.@ You@ should@ explicitly@ \ annotate@ the@ declaration@ of@ %a@ with@ %a@ or@ %a,@ so@ that@ its@ \ external@ interface@ remains@ stable@ in@ the future." Style.inline_code t Style.inline_code t Style.inline_code "[@@boxed]" Style.inline_code "[@@unboxed]" | Constraint_on_gadt -> msg "Type constraints do not apply to@ GADT@ cases@ of@ variant types." | Erroneous_printed_signature s -> msg "The printed@ interface@ differs@ from@ the@ inferred@ interface.@ \ The@ inferred@ interface@ contained@ items@ which@ could@ not@ be@ \ printed@ properly@ due@ to@ name@ collisions@ between@ identifiers.@ \ %s@ \ Beware@ that@ this@ warning@ is@ purely@ informational@ and@ will@ \ not@ catch@ all@ instances@ of@ erroneous@ printed@ interface." s | Unsafe_array_syntax_without_parsing -> msg "option@ %a@ used with a preprocessor returning@ a@ syntax tree" Style.inline_code "-unsafe" | Redefining_unit name -> let def ppf name = Fmt.fprintf ppf "type %s = unit" name in msg "This type declaration is@ defining@ a new %a constructor@ \ which@ shadows@ the@ existing@ one.@ \ %t: Did you mean %a?" Style.inline_code "()" Style.hint (Style.as_inline_code def) name | Unused_functor_parameter s -> msg "unused functor parameter %a." Style.inline_code s | Match_on_mutable_state_prevent_uncurry -> msg "This pattern depends on@ mutable@ state.@ It prevents@ the@ \ remaining@ arguments@ from@ being@ uncurried,@ which will@ cause@ \ additional@ closure@ allocations." | Unused_field (s, Unused) -> msg "unused record field %a." Style.inline_code s | Unused_field (s, Not_read) -> msg "record field %a is never read.@ \ (However, this field is used to build or mutate values.)" Style.inline_code s | Unused_field (s, Not_mutated) -> msg "mutable record field %a is never mutated." Style.inline_code s | Missing_mli -> msg "Cannot find interface file." | Unused_tmc_attribute -> msg "This function is marked %a@ \ but is never applied in TMC position." Style.inline_code "@tail_mod_cons" | Tmc_breaks_tailcall -> msg "This call@ is@ in@ tail-modulo-cons@ position@ in@ a@ TMC@ \ function,@ but@ the@ function@ called@ is@ not@ itself@ \ specialized@ for@ TMC,@ so@ the@ call@ will@ not@ be@ transformed@ \ into@ a@ tail@ call.@ \ @[Please@ either@ mark@ the@ called@ function@ with@ the %a@ \ attribute,@ or@ mark@ this@ call@ with@ the@ %a@ attribute@ to@ \ make@ its@ non-tailness@ explicit.@]" Style.inline_code "[@tail_mod_cons]" Style.inline_code "[@tailcall false]" | Generative_application_expects_unit -> msg "A generative functor@ \ should be applied@ to@ %a;@ using@ %a@ is deprecated." Style.inline_code "()" Style.inline_code "(struct end)" | Degraded_to_partial_match -> let[@manual.ref "ss:warn74"] ref_manual = [ 13; 5; 5 ] in msg "This pattern-matching@ is@ compiled@ as@ partial,@ even@ if@ it@ \ appears@ to@ be@ total.@ It@ may@ generate@ a@ %a@ exception.@ This@ \ typically@ occurs@ due@ to@ complex@ matches@ on@ mutable@ fields.@ %a" Style.inline_code "Match_failure" Misc.print_see_manual ref_manual | Unnecessarily_partial_tuple_pattern -> msg "This tuple pattern@ unnecessarily@ ends in %a,@ as@ it@ explicitly@ \ matches@ all@ components@ of@ its@ expected@ type." Style.inline_code ".." ;; let nerrors = ref 0 type reporting_information = { id : string ; message : Fmt.doc ; is_error : bool ; sub_locs : (loc * Fmt.doc) list; } let id_name w = let n = number w in match List.find_opt (fun {number; _} -> number = n) descriptions with | Some {names = s :: _; _} -> Printf.sprintf "%d [%s]" n s | _ -> string_of_int n let report w = match is_active w with | false -> `Inactive | true -> if is_error w then incr nerrors; `Active { id = id_name w; message = message w; is_error = is_error w; sub_locs = []; } let report_alert (alert : alert) = match alert_is_active alert with | false -> `Inactive | true -> let is_error = alert_is_error alert in if is_error then incr nerrors; let message = msg "%s" (Misc.normalise_eol alert.message) in (* Reduce \r\n to \n: - Prevents any \r characters being printed on Unix when processing Windows sources - Prevents \r\r\n being generated on Windows, which affects the testsuite *) let sub_locs = if not alert.def.loc_ghost && not alert.use.loc_ghost then [ alert.def, msg "Definition"; alert.use, msg "Expected signature"; ] else [] in `Active { id = alert.kind; message; is_error; sub_locs; } exception Errors let reset_fatal () = nerrors := 0 let check_fatal () = if !nerrors > 0 then begin nerrors := 0; raise Errors; end let pp_since out release_info = Printf.fprintf out " (since %d.%0*d)" release_info.Sys.major (if release_info.Sys.major >= 5 then 0 else 2) release_info.Sys.minor let help_warnings () = List.iter (fun {number; description; names; since} -> let name = match names with | s :: _ -> " [" ^ s ^ "]" | [] -> "" in Printf.printf "%3i%s %s%a\n" number name description (fun out -> Option.iter (pp_since out)) since) descriptions; print_endline " A all warnings"; for i = Char.code 'b' to Char.code 'z' do let c = Char.chr i in match letter c with | [] -> () | [n] -> Printf.printf " %c Alias for warning %i.\n" (Char.uppercase_ascii c) n | l -> Printf.printf " %c warnings %s.\n" (Char.uppercase_ascii c) (String.concat ", " (List.map Int.to_string l)) done; exit 0