1 files changed, 32 insertions, 7 deletions
diff --git a/utils/warnings.ml b/utils/warnings.ml
index 33c85ba36..28bf42456 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -41,7 +41,8 @@ let check c =
   with _ -> raise (Arg.Bad (Printf.sprintf "unknown warning option %c" c))
 ;;    
 
-let flags = Array.create 26 true;;
+let active = Array.create 26 true;;
+let error = Array.create 26 false;;
 
 let translate c =
   check c;
@@ -51,7 +52,18 @@ let translate c =
     (Char.code c - Char.code 'a', false)
 ;;
 
-let parse_options s =
+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
@@ -62,11 +74,6 @@ let parse_options s =
   done
 ;;
 
-let is_active x =
-  let (n, _) = translate (letter x) in
-  flags.(n)
-;;
-
 let message = function
   | Partial_match "" -> "this pattern-matching is not exhaustive."
   | Partial_match s ->
@@ -88,3 +95,21 @@ let message = function
   | Comment s -> "this is " ^ s ^ "."
   | Other s -> s
 ;;
+
+let nerrors = ref 0;;
+
+let print ppf w =
+  Format.fprintf ppf "%s" (message w);
+  let (n, _) = translate (letter w) in
+  if error.(n) then incr nerrors;
+;;
+
+exception Errors of int;;
+
+let check_fatal () =
+  if !nerrors > 0 then begin
+    let e = Errors !nerrors in
+    nerrors := 0;
+    raise e;
+  end;
+;;