Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 289 lines (243 sloc) 9.117 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19
20 type wclass = {
21 mutable loaded : bool;
22 toplevel : bool;
23 name : string;
24 doc : string;
25 public : bool ;
26 mutable err : bool; (* whether triggering this warning is an error *)
27 mutable enable : bool; (* true means the warning/error is enabled *)
28 mutable children : wclass list; (* to implement a hierarchy of warnings *)
29 }
30
31 module S =
32 struct
33 type 'a t = wclass constraint 'a = _ * _ * _
34 let subs_cons ({children=children} as wclass) =
35 (fun children -> wclass.children <- children; wclass), children
36 end
37 module Traverse = Traverse.Make(S)
38
39 let root_warning = {
40 loaded = true ; (* don't really care, this warning is the start point anyway *)
41 toplevel = true ; (* idem *)
42 name = "root" ;
43 doc = "Regroups all the warnings of the compiler" ;
44 public = true ;
45 err = false ; (* don't really care, this warning shouldn't be used anyway *)
46 enable = true ; (* don't really care, this warning shouldn't be used anyway *)
47 children = [] ;
48 }
49
50 let get_children wclass name =
51 List.find (fun {name=name'} -> name = name') wclass.children
52 let has_children wclass name =
53 try ignore (get_children wclass name); true with Not_found -> false
54
55 let create ?parent ?(public=false) ~name ~doc ~err ~enable () =
56 let wclass =
57 let loaded = false in
58 let toplevel = Option.is_none parent in
59 let name =
60 match parent with
61 | Some parent when parent != root_warning -> parent.name^"."^name
62 | _ -> name
63 in
64 {
65 loaded = loaded ;
66 toplevel = toplevel ;
67 name = name ;
68 doc = doc ;
69 public = public ;
70 err = err ;
71 enable = enable ;
72 children = [] ;
73 } in
74 let _ =
75 match parent with
76 | Some parent ->
77 assert (not (has_children parent name));
78 parent.children <- wclass :: parent.children
79 | _ -> ()
80 in
81 wclass
82
83 module Set =
84 struct
85 type t = wclass Stack.t
86 let create () : t = Stack.create ()
87 let add t (w:wclass) = Stack.push w t
88 let add_all t wl = List.iter (add t) wl
89 let add_set t t' = Stack.iter (add t) t'
90 let create_from_list l =
91 let t = create () in
92 add_all t l;
93 t
94 end
95
96 let load w =
97 Traverse.iter (fun w -> w.loaded <- true) w;
98 if w.toplevel
99 then (
100 try
101 let w' = get_children root_warning w.name in
102 if w != w' then (
103 (* cannot call OManager :( *)
104 Printf.eprintf "You have different warning classes called %s:\n %s\nand\n %s\n%!"
105 w.name
106 w.doc
107 w'.doc;
108 assert false
109 )
110 with Not_found ->
111 root_warning.children <- w :: root_warning.children
112 )
113 ;
114 ()
115
116 let load_set set =
117 Stack.iter load set
118
119 let set_warn_error_not_rec wclass b = wclass.err <- b
120 let set_warn_error wclass b = Traverse.iter (fun wclass -> set_warn_error_not_rec wclass b) wclass
121 let is_warn_error wclass = wclass.loaded && wclass.err
122
123 let set_warn_not_rec wclass b = wclass.enable <- b
124 let set_warn wclass b = Traverse.iter (fun wclass -> set_warn_not_rec wclass b) wclass
125 let is_warn wclass = wclass.loaded && wclass.enable
126
127 let get_doc wclass = wclass.doc
128 let get_name wclass = wclass.name
129
130 let get_from_path sl =
131 let rec aux wclass = function
132 | [] -> Some wclass
133 | s :: tl ->
134 aux (get_children wclass s) tl in
135 try aux root_warning sl with Not_found -> None
136
137 let rec fold_with_env f acc env wclass =
138 let acc, env = f acc env wclass in
139 List.fold_left (fun acc wclass -> fold_with_env f acc env wclass) acc wclass.children
140
141 let fold f acc =
142 fold_with_env
143 (fun acc env wclass ->
144 let path = env @ [wclass.name] in
145 let acc =
146 if wclass.loaded
147 then f acc path wclass
148 else acc
149 in
150 acc, path) acc [] root_warning
151
152 (* OManager depends on WarningClass *)
153 let printf = Printf.eprintf
154
155 module Arg =
156 struct
157 module A = Base.Arg
158 let find_set set b name =
159 match Traverse.find (fun w -> String.compare name w.name = 0) root_warning with
160 | Some w -> set w b
161 | None ->
162 printf "There is no such warning-class : '%s'\n" name ;
163 printf "Hint: try '--warn-help'\n";
164 exit 1
165
166 let warn = find_set set_warn
167 let warn_error = find_set set_warn_error
168
169 let help () =
170 (* Alphabetic order *)
171 let extract w = w.name, w.doc, w.enable, w.err in
172 let unsorted = Traverse.fold
173 (fun acc w -> if w == root_warning || not w.loaded then acc
174 else (extract w)::acc) [] root_warning in
175 let sorted = (extract root_warning) :: (List.sort (fun (m, _, _, _) (n, _, _, _) -> String.compare m n) unsorted) in
176 let pprt b = if b then "Printed" else "NotPrinted" in
177 let perr b = if b then "Error" else "Warning" in
178 let iter (name, doc, prt, err) =
179 printf "+ %s: %s %s\n\t%s\n\n" name (pprt prt) (perr err) doc
180 in
181 printf "List of available warning-classes\n" ;
182 printf "wclass: warn warn-error (default value)\n\n" ;
183 List.iter iter sorted ;
184 exit 0
185
ee9137a [cleanup] options: removed useless () argument to cmdline options
Mathieu Baudet authored
186 let options = [
fccc685 Initial open-source release
MLstate authored
187 ("--warn", A.String (warn true), "<wclass> Activate a warning class");
188 ("--no-warn", A.String (warn false), "<wclass> Deactivate a warning class");
189 ("--warn-error", A.String (warn_error true), "<wclass> Warnings of the class will be considered as errors");
190 ("--no-warn-error", A.String (warn_error false), "<wclass> Warnings of the class will not be considered as errors");
191 ("--warn-help", A.Unit help, " Print the list of warning-classes");
192 (*TODO: --warn-bash-completion *)
193 ]
194 end
195
196 (* **********************************************)
197 (* ADD YOUR WARNING CLASS HERE ******************)
198 (* AND COMMENT MLI ******************************)
199 (* **********************************************)
200
201 (*
202 GUIDELINES:
203 -----------
204
205 1) Beware, if your warning is meant to be public,
206 think about what you write in the documentation.
207 External user do not have access to sources,
208 and to name of AST nodes, structures, libname,
209 etc...
210
211 2) Names :
212 You must necessary use the hierachy.
213 The constructor already implements the name concatenation
214 for making the Arg command line,
215 so do not repeat the name of the parent.
216
217 *)
218
219 let bsl =
220 let doc = "Link with external primitives" in
221 create ~name:"bsl" ~doc ~err:false ~enable:true ()
222
223 let bsl_backend_restriction =
224 let doc = "Backend Restriction" in
225 create ~parent:bsl ~name:"backend-restriction" ~doc ~err:false ~enable:true ()
226
227 let bsl_loading =
228 let doc = "Plugin Loading" in
229 create ~parent:bsl ~name:"loading" ~doc ~err:false ~enable:true ()
230
231 let bsl_projection =
232 let doc = "External Primitive Projection" in
233 create ~parent:bsl ~name:"projection" ~doc ~err:false ~enable:true ()
234
235 let bsl_register =
236 let doc = "External Primitive Plugin Builder" in
237 create ~parent:bsl ~name:"register" ~doc ~err:false ~enable:true ()
238
239 let bsl_type_checking =
240 let doc = "Type checking" in
241 create ~parent:bsl ~name:"type-checking" ~doc ~err:false ~enable:true ()
242
243 let bsl_unknown_bypass =
244 let doc = "Unknown external primitive" in
245 create ~parent:bsl ~name:"unknown-bypass" ~doc ~err:false ~enable:true ()
246
247 (* CONDITIONS *)
248
249 let cond =
250 let doc = "Pre/Post condition violation" in
251 create ~name:"cond" ~doc ~err:true ~enable:true ()
252
253
254 (* DbGen ******************************)
255 let dbgen =
256 create ~name:"dbgen" ~doc:"Database resolution" ~err:false ~enable:true ()
257
258 let dbgen_schema =
259 create ~parent:dbgen ~name:"schema" ~doc:"Database Schemas" ~err:false ~enable:true ()
260
261 (* Explicit instantiation *************)
262 let ei =
263 let doc = "Explicit instantiation warnings" in
264 create ~name:"ei" ~doc ~err:false ~enable:true ()
265 let ei_generalize =
266 let doc = "Generalize a non-functionnal value" in
267 create ~name:"generalize" ~doc ~err:false ~enable:false ()
268
269 (* Phandler ***************************)
270 let phandler =
271 let doc = "Pass system warnings" in
272 create ~name:"phandler" ~doc ~err:false ~enable:true ()
273 let phandler_consistency =
274 let doc = "Warn if the pass system is not consistent" in
275 create ~parent:phandler ~name:"consistency" ~doc ~err:false ~enable:true ()
276
277 (* Commons ****************************)
278 let warn =
279 let doc = "Commons warnings that can used at any step of compilations" in
280 create ~name:"warn" ~doc ~err:false ~enable:true ()
281 let warn_olevel =
282 let doc = "Warn if an optimization level is wrong" in
283 create ~parent:phandler ~name:"consistency" ~doc ~err:false ~enable:true ()
284
285 (* Pattern Matching *******************)
286 let pattern =
287 let doc = "Warnings related to pattern matching" in
288 create ~name:"pattern" ~doc ~err:false ~enable:true ()
Something went wrong with that request. Please try again.