Additional test for color output.

Color output is only enabled if stderr is a tty, and the
environment variable TERM is not empty or dumb.
Bug 18004

2 files changed, 59 insertions, 39 deletions

diff --git a/cparser/Cerrors.ml b/cparser/Cerrors.ml
index f2794a2c..8ee13caf 100644
--- a/cparser/Cerrors.ml
+++ b/cparser/Cerrors.ml
@@ -18,9 +18,10 @@
 open Format
 open Commandline
 
-let warn_error = ref false
 let error_fatal = ref false
-let color_diagnostics = ref true
+let color_diagnostics =
+  let term = try Sys.getenv "TERM" with Not_found -> "" in
+  ref (Unix.isatty Unix.stderr && term <> "dumb" && term <>"")
 
 let num_errors = ref 0
 let num_warnings = ref 0
@@ -106,20 +107,20 @@ let string_of_warning = function
   | Literal_range -> "literal-range"
   | Unknown_pragmas -> "unknown-pragmas"
 
-let activate_warning w =
+let activate_warning w () =
   if not (List.mem w !active_warnings) then
     active_warnings:=w::!active_warnings
 
-let deactivate_warning w =
+let deactivate_warning w  () =
   active_warnings:=List.filter ((<>) w) !active_warnings;
   error_warnings:= List.filter ((<>) w) !error_warnings
 
-let warning_as_error w =
-  activate_warning w;
+let warning_as_error w ()=
+  activate_warning w ();
   if not (List.mem w !error_warnings) then
     error_warnings := w::!error_warnings
 
-let warning_not_as_error w =
+let warning_not_as_error w () =
   error_warnings:= List.filter ((<>) w) !error_warnings
 
 let wall () =
@@ -256,18 +257,14 @@ let check_errors () =
     eprintf "@[<hov 0>%d error%s detected.@]@."
             !num_errors
             (if !num_errors = 1 then "" else "s");
-  if !warn_error && !num_warnings > 0 then
-    eprintf "@[<hov 0>%d error-enabled warning%s detected.@]@."
-            !num_warnings
-            (if !num_warnings = 1 then "" else "s");
-  !num_errors > 0 || (!warn_error && !num_warnings > 0)
+  !num_errors > 0
 
 let error_option w =
   let key = string_of_warning w in
-  [Exact ("-W"^key), Self (fun _ -> activate_warning w);
-   Exact ("-Wno"^key), Self (fun _ -> deactivate_warning w);
-   Exact ("-Werror="^key), Self (fun _ -> warning_as_error w);
-   Exact ("-Wno-error="^key), Self (fun _ -> warning_not_as_error w)]
+  [Exact ("-W"^key), Unit (activate_warning w);
+   Exact ("-Wno"^key), Unit (deactivate_warning w);
+   Exact ("-Werror="^key), Unit ( warning_as_error w);
+   Exact ("-Wno-error="^key), Unit ( warning_not_as_error w)]
 
 let warning_options =
   error_option Unnamed @
@@ -289,10 +286,10 @@ let warning_options =
   error_option Literal_range @
   error_option Unknown_pragmas @
   [Exact ("-Wfatal-errors"), Set error_fatal;
-   Exact ("-fdiagnostics-color"), Set color_diagnostics;
+   Exact ("-fdiagnostics-color"), Ignore; (* Either output supports it or no color *)
    Exact ("-fno-diagnostics-color"), Unset color_diagnostics;
-   Exact ("-Werror"), Self (fun _ -> werror ());
-   Exact ("-Wall"), Self (fun _ -> wall());]
+   Exact ("-Werror"), Unit werror;
+   Exact ("-Wall"), Unit wall;]
 
 let warning_help = "Diagnostic options:\n\
 \  -W<warning>        Enable the specific <warning>\n\
diff --git a/cparser/Cerrors.mli b/cparser/Cerrors.mli
index 3010241a..b312931a 100644
--- a/cparser/Cerrors.mli
+++ b/cparser/Cerrors.mli
@@ -13,35 +13,58 @@
 (*                                                                     *)
 (* *********************************************************************)
 
-val warn_error : bool ref
+(* Printing of warnings and error messages *)
+
 val reset : unit -> unit
+  (** Reset the error counters. *)
+
 exception Abort
-val fatal_error_raw : ('a, out_channel, unit, 'b) format4 -> 'a
+  (** Exception raised upon fatal errors *)
+
 val check_errors : unit -> bool
+  (** Check whether errors occured *)
 
 type warning_type =
-  | Unnamed
-  | Unknown_attribute
-  | Zero_length_array
-  | Celeven_extension
-  | Gnu_empty_struct
-  | Missing_declarations
-  | Constant_conversion
-  | Int_conversion
-  | Varargs
-  | Implicit_function_declaration
-  | Pointer_type_mismatch
-  | Compare_distinct_pointer_types
-  | Pedantic
-  | Main_return_type
-  | Invalid_noreturn
-  | Return_type
-  | Literal_range
-  | Unknown_pragmas
+  | Unnamed                        (** warnings which cannot be turned off *)
+  | Unknown_attribute              (** usage of unsupported/unknown attributes *)
+  | Zero_length_array              (** gnu extension for zero lenght arrays *)
+  | Celeven_extension              (** C11 fetatures *)
+  | Gnu_empty_struct               (** gnu extension for empty struct *)
+  | Missing_declarations           (** declation which do not declare anything *)
+  | Constant_conversion            (** dangerous constant conversions *)
+  | Int_conversion                 (** pointer <-> int conversions *)
+  | Varargs                        (** promotable vararg argument *)
+  | Implicit_function_declaration  (** deprecated implicit function declaration *)
+  | Pointer_type_mismatch          (** pointer type mismatch in ?: operator *)
+  | Compare_distinct_pointer_types (** comparison between different pointer types *)
+  | Pedantic                       (** non C99 code *)
+  | Main_return_type               (** wrong return type for main *)
+  | Invalid_noreturn               (** noreturn function containing return *)
+  | Return_type                    (** void return in non-void function *)
+  | Literal_range                  (** literal ranges *)
+  | Unknown_pragmas                (** unknown/unsupported pragma *)
 
 val warning  : (string * int) -> warning_type -> ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a
+(** [warning (f,c) w fmt arg1 ... argN] formats the arguments [arg1] to [argN] as warining according to
+    the format string [fmt] and outputs the result on [stderr] with additional file [f] and column [c]
+    and warning key for [w] *)
+
 val error : (string * int) -> ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a
+(** [error (f,c) w fmt arg1 ... argN] formats the arguments [arg1] to [argN] as error according to
+    the format string [fmt] and outputs the result on [stderr] with additional file [f] and column [c]
+    and warning key for [w]. *)
+
 val fatal_error : (string * int) -> ('a, Format.formatter, unit, unit, unit, 'b) format6 -> 'a
+(** [fatal_error (f,c) w fmt arg1 ... argN] formats the arguments [arg1] to [argN] as error according to
+    the format string [fmt] and outputs the result on [stderr] with additional file [f] and column [c]
+    and warning key for [w]. Additionally raises the excpetion [Abort] after printing the error message *)
+
+val fatal_error_raw : ('a, out_channel, unit, 'b) format4 -> 'a
+(** [fatal_error_raw] is identical to fatal_error, except it uses [Printf] and does not automatically
+    introduce indentation *)
 
 val warning_help : string
+(** Help string for all warning options *)
+
 val warning_options : (Commandline.pattern * Commandline.action) list
+(** List of all options for diagnostics *)