1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
(***********************************************************************)
(* *)
(* 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$ *)
(* Please keep them in alphabetical order *)
type t = (* A is all *)
| Comment of string (* C *)
| Deprecated (* D *)
| Fragile_pat of string (* E *)
| Partial_application (* F *)
| Labels_omitted (* L *)
| Method_override of string list (* M *)
| Partial_match of string (* P *)
| Statement_type (* S *)
| Unused_match (* U *)
| Unused_pat (* U *)
| Hide_instance_variable of string (* V *)
| Other of string (* X *)
;;
let letter = function (* 'a' is all *)
| Comment _ -> 'c'
| Deprecated -> 'd'
| Fragile_pat _ -> 'e'
| Partial_application -> 'f'
| Labels_omitted -> 'l'
| Method_override _ -> 'm'
| Partial_match _ -> 'p'
| Statement_type -> 's'
| Unused_match|Unused_pat -> 'u'
| Hide_instance_variable _ -> 'v'
| Other _ -> 'x'
;;
let check c =
try ignore (String.index "acdeflmpsuvxACDEFLMPSUVX" c)
with _ -> raise (Arg.Bad (Printf.sprintf "unknown warning option %c" c))
;;
let active = Array.make 26 true;;
let error = Array.make 26 false;;
let translate c =
check c;
if c >= 'A' && c <= 'Z' then
(Char.code c - Char.code 'A', true)
else
(Char.code c - Char.code 'a', false)
;;
let is_active x =
let (n, _) = translate (letter x) in
active.(n)
;;
let is_error x =
let (n, _) = translate (letter x) in
error.(n)
;;
let parse_options iserr s =
let flags = if iserr then error else active in
for i = 0 to String.length s - 1 do
if s.[i] = 'A' then Array.fill flags 0 (Array.length flags) true
else if s.[i] = 'a' then Array.fill flags 0 (Array.length flags) false
else begin
let (n, fl) = translate s.[i] in
flags.(n) <- fl;
end;
done
;;
let () = parse_options false "el";;
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 pattern is unused."
| Fragile_pat "" ->
"this pattern is fragile. It would hide\n\
the addition of new constructors to the data types it matches."
| Fragile_pat s ->
"this pattern is fragile. It would hide\n\
the addition of new constructors to the data types it matches.\n\
Here is an example of a more robust pattern:\n" ^ s
| Labels_omitted ->
"labels were omitted in the application of this function."
| Method_override slist ->
String.concat " "
("the following methods are overriden \
by the inherited class:\n " :: slist)
| Hide_instance_variable lab ->
"this definition of an instance variable " ^ lab ^
" hides a previously\ndefined instance variable of the same name."
| Partial_application ->
"this function application is partial,\n\
maybe some arguments are missing."
| Statement_type ->
"this expression should have type unit."
| Comment s -> "this is " ^ s ^ "."
| Deprecated -> "this syntax is deprecated."
| Other s -> s
;;
let nerrors = ref 0;;
let print ppf w =
let msg = message 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 f =
Format.pp_get_formatter_out_functions ppf ()
in
let countnewline x = incr newlines; f.out_newline x in
Format.pp_set_formatter_out_functions ppf { f with out_newline = countnewline };
Format.fprintf ppf "%s" msg;
Format.pp_print_flush ppf ();
Format.pp_set_formatter_out_functions ppf f;
let (n, _) = translate (letter w) in
if error.(n) 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;
;;
|
