278 lines
9.6 KiB
OCaml
278 lines
9.6 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* 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 Q Public License version 1.0. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
(* When you change this, you need to update the documentation:
|
|
- man/ocamlc.m in ocaml
|
|
- man/ocamlopt.m in ocaml
|
|
- manual/cmds/comp.etex in the doc sources
|
|
- manual/cmds/native.etex in the doc sources
|
|
*)
|
|
|
|
type t =
|
|
| Comment_start (* 1 *)
|
|
| Comment_not_end (* 2 *)
|
|
| Deprecated (* 3 *)
|
|
| Fragile_match of string (* 4 *)
|
|
| Partial_application (* 5 *)
|
|
| Labels_omitted (* 6 *)
|
|
| Method_override of string list (* 7 *)
|
|
| Partial_match of string (* 8 *)
|
|
| Non_closed_record_pattern of string (* 9 *)
|
|
| Statement_type (* 10 *)
|
|
| Unused_match (* 11 *)
|
|
| Unused_pat (* 12 *)
|
|
| Instance_variable_override of string (* 13 *)
|
|
| Illegal_backslash (* 14 *)
|
|
| Implicit_public_methods of string list (* 15 *)
|
|
| Unerasable_optional_argument (* 16 *)
|
|
| Undeclared_virtual_method of string (* 17 *)
|
|
| Not_principal of string (* 18 *)
|
|
| Without_principality of string (* 19 *)
|
|
| Unused_argument (* 20 *)
|
|
| Nonreturning_statement (* 21 *)
|
|
| Camlp4 of string (* 22 *)
|
|
| All_clauses_guarded (* 23 *)
|
|
| Useless_record_with (* 24 *)
|
|
| Bad_module_name of string (* 25 *)
|
|
| Unused_var of string (* 26 *)
|
|
| Unused_var_strict of string (* 27 *)
|
|
| Wildcard_arg_to_constant_constr (* 28 *)
|
|
| Eol_in_string (* 29 *)
|
|
;;
|
|
|
|
(* 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.
|
|
*)
|
|
|
|
let number = function
|
|
| Comment_start -> 1
|
|
| Comment_not_end -> 2
|
|
| Deprecated -> 3
|
|
| Fragile_match _ -> 4
|
|
| Partial_application -> 5
|
|
| Labels_omitted -> 6
|
|
| Method_override _ -> 7
|
|
| Partial_match _ -> 8
|
|
| Non_closed_record_pattern _ -> 9
|
|
| Statement_type -> 10
|
|
| Unused_match -> 11
|
|
| Unused_pat -> 12
|
|
| Instance_variable_override _ -> 13
|
|
| Illegal_backslash -> 14
|
|
| Implicit_public_methods _ -> 15
|
|
| Unerasable_optional_argument -> 16
|
|
| Undeclared_virtual_method _ -> 17
|
|
| Not_principal _ -> 18
|
|
| Without_principality _ -> 19
|
|
| Unused_argument -> 20
|
|
| Nonreturning_statement -> 21
|
|
| Camlp4 _ -> 22
|
|
| Useless_record_with -> 23
|
|
| Bad_module_name _ -> 24
|
|
| All_clauses_guarded -> 25
|
|
| Unused_var _ -> 26
|
|
| Unused_var_strict _ -> 27
|
|
| Wildcard_arg_to_constant_constr -> 28
|
|
| Eol_in_string -> 29
|
|
;;
|
|
|
|
let last_warning_number = 29;;
|
|
(* 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' -> []
|
|
| '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; 25]
|
|
| 'y' -> [26]
|
|
| 'z' -> [27]
|
|
| _ -> assert false
|
|
;;
|
|
|
|
let active = Array.create (last_warning_number + 1) true;;
|
|
let error = Array.create (last_warning_number + 1) false;;
|
|
|
|
let is_active x = active.(number x);;
|
|
let is_error x = error.(number x);;
|
|
|
|
let parse_opt flags s =
|
|
let check i =
|
|
if i < 1 then raise (Arg.Bad "Bad warning number 0");
|
|
if i > last_warning_number then
|
|
raise (Arg.Bad "Bad warning number (too large)");
|
|
in
|
|
let set i = flags.(i) <- true in
|
|
let clear i = flags.(i) <- false in
|
|
let set_all i = active.(i) <- true; error.(i) <- true in
|
|
let error () = raise (Arg.Bad "Ill-formed list of warnings") in
|
|
let rec loop i =
|
|
if i >= String.length s then () else
|
|
match s.[i] with
|
|
| 'A' .. 'Z' ->
|
|
List.iter set (letter (Char.lowercase s.[i]));
|
|
loop (i+1)
|
|
| 'a' .. 'z' ->
|
|
List.iter clear (letter s.[i]);
|
|
loop (i+1)
|
|
| '+' -> loop_letter_num set (i+1)
|
|
| '-' -> loop_letter_num clear (i+1)
|
|
| '@' -> loop_letter_num set_all (i+1)
|
|
| c -> error ()
|
|
and loop_letter_num myset i =
|
|
if i >= String.length s then error () else
|
|
match s.[i] with
|
|
| '0' .. '9' -> loop_num myset i 0
|
|
| 'A' .. 'Z' ->
|
|
List.iter myset (letter (Char.lowercase s.[i]));
|
|
loop (i+1)
|
|
| 'a' .. 'z' ->
|
|
List.iter myset (letter s.[i]);
|
|
loop (i+1)
|
|
| _ -> error ()
|
|
and loop_num myset i n =
|
|
if i >= String.length s then myset n else
|
|
match s.[i] with
|
|
| '0' .. '9' ->
|
|
let nn = 10 * n + Char.code s.[i] - Char.code '0' in
|
|
check nn;
|
|
loop_num myset (i+1) nn
|
|
| _ -> myset n; loop i
|
|
in
|
|
loop 0
|
|
;;
|
|
|
|
let parse_options errflag s = parse_opt (if errflag then error else active) s;;
|
|
|
|
let defaults_w = "+a-4-6-9-27-28";;
|
|
let defaults_warn_error = "-a";;
|
|
|
|
let () = parse_options false defaults_w;;
|
|
let () = parse_options true defaults_warn_error;;
|
|
|
|
let message = function
|
|
| Partial_match "" -> "this pattern-matching is not exhaustive."
|
|
| Partial_match s ->
|
|
"this pattern-matching is not exhaustive.\n\
|
|
Here is an example of a value that is not matched:\n" ^ s
|
|
| Unused_match -> "this match case is unused."
|
|
| Unused_pat -> "this sub-pattern is unused."
|
|
| Fragile_match "" ->
|
|
"this pattern-matching is fragile."
|
|
| Fragile_match s ->
|
|
"this pattern-matching is fragile.\n\
|
|
It will remain exhaustive when constructors are added to type " ^ s ^ "."
|
|
| Non_closed_record_pattern s ->
|
|
"the following labels are not bound in this record pattern:\n" ^ s ^
|
|
"\nEither bind these labels explicitly or add `; _' to the pattern."
|
|
| Labels_omitted ->
|
|
"labels were omitted in the application of this function."
|
|
| Method_override [lab] ->
|
|
"the method " ^ lab ^ " is overridden in the same class."
|
|
| Method_override (cname :: slist) ->
|
|
String.concat " "
|
|
("the following methods are overriden by the class"
|
|
:: cname :: ":\n " :: slist)
|
|
| Method_override [] -> assert false
|
|
| Instance_variable_override lab ->
|
|
"the instance variable " ^ lab ^ " is overridden.\n" ^
|
|
"The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
|
|
| Partial_application ->
|
|
"this function application is partial,\n\
|
|
maybe some arguments are missing."
|
|
| Statement_type ->
|
|
"this expression should have type unit."
|
|
| Comment_start -> "this is the start of a comment."
|
|
| Comment_not_end -> "this is not the end of a comment."
|
|
| Deprecated -> "this syntax is deprecated."
|
|
| Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "."
|
|
| Illegal_backslash -> "illegal backslash escape in string."
|
|
| Implicit_public_methods l ->
|
|
"the following private methods were made public implicitly:\n "
|
|
^ String.concat " " l ^ "."
|
|
| Unerasable_optional_argument -> "this optional argument cannot be erased."
|
|
| Undeclared_virtual_method m -> "the virtual method "^m^" is not declared."
|
|
| Not_principal s -> s^" is not principal."
|
|
| Without_principality s -> s^" without principality."
|
|
| Unused_argument -> "this argument will not be used by the function."
|
|
| Nonreturning_statement ->
|
|
"this statement never returns (or has an unsound type.)"
|
|
| Camlp4 s -> s
|
|
| All_clauses_guarded ->
|
|
"bad style, all clauses in this pattern-matching are guarded."
|
|
| Useless_record_with ->
|
|
"this record is defined by a `with' expression,\n\
|
|
but no fields are borrowed from the original."
|
|
| Bad_module_name (modname) ->
|
|
"bad source file name: \"" ^ modname ^ "\" is not a valid module name."
|
|
| Wildcard_arg_to_constant_constr ->
|
|
"wildcard pattern given as argument to a constant constructor"
|
|
| Eol_in_string ->
|
|
"unescaped end-of-line in a string constant (non-portable code)"
|
|
;;
|
|
|
|
let nerrors = ref 0;;
|
|
|
|
let print ppf w =
|
|
let msg = message w in
|
|
let num = number w in
|
|
let newlines = ref 0 in
|
|
for i = 0 to String.length msg - 1 do
|
|
if msg.[i] = '\n' then incr newlines;
|
|
done;
|
|
let (out, flush, newline, space) =
|
|
Format.pp_get_all_formatter_output_functions ppf ()
|
|
in
|
|
let countnewline x = incr newlines; newline x in
|
|
Format.pp_set_all_formatter_output_functions ppf out flush countnewline space;
|
|
Format.fprintf ppf "%d: %s" num msg;
|
|
Format.pp_print_flush ppf ();
|
|
Format.pp_set_all_formatter_output_functions ppf out flush newline space;
|
|
if error.(num) then incr nerrors;
|
|
!newlines
|
|
;;
|
|
|
|
exception Errors of int;;
|
|
|
|
let check_fatal () =
|
|
if !nerrors > 0 then begin
|
|
let e = Errors !nerrors in
|
|
nerrors := 0;
|
|
raise e;
|
|
end;
|
|
;;
|