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

6 files changed, 102 insertions, 75 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 *)
diff --git a/driver/Commandline.ml b/driver/Commandline.ml
index 0a2c8fca..c5c2b82c 100644
--- a/driver/Commandline.ml
+++ b/driver/Commandline.ml
@@ -31,6 +31,8 @@ type action =
   | Self of (string -> unit)
   | String of (string -> unit)
   | Integer of (int -> unit)
+  | Ignore
+  | Unit of (unit -> unit)
 
 let match_pattern text = function
   | Exact s ->
@@ -95,6 +97,8 @@ let parse_array spec argv first last =
           end else begin
             eprintf "Option `%s' expects an argument\n" s; exit 2
           end
+      | Some (Ignore) -> parse (i+1)
+      | Some (Unit f) -> f (); parse (i+1)
     end
   in parse first
 
diff --git a/driver/Commandline.mli b/driver/Commandline.mli
index 79786678..5f9d8704 100644
--- a/driver/Commandline.mli
+++ b/driver/Commandline.mli
@@ -33,6 +33,8 @@ type action =
   | Self of (string -> unit)    (** call the function with the matched string *)
   | String of (string -> unit)  (** read next arg as a string, call function *)
   | Integer of (int -> unit)    (** read next arg as an int, call function *)
+  | Ignore                      (** ignore the arg *)
+  | Unit of (unit -> unit)      (** call the function with unit as argument *)
 
 val parse_cmdline: (pattern * action) list -> unit
 
diff --git a/driver/Driver.ml b/driver/Driver.ml
index 038bd423..78baed47 100644
--- a/driver/Driver.ml
+++ b/driver/Driver.ml
@@ -348,10 +348,10 @@ General options:\n\
 \  -random        Randomize execution order\n\
 \  -all           Simulate all possible execution orders\n"
 
-let print_usage_and_exit _ =
+let print_usage_and_exit () =
   printf "%s" usage_string; exit 0
 
-let print_version_and_exit _ =
+let print_version_and_exit () =
   printf "%s" version_string; exit 0
 
 let language_support_options = [
@@ -364,8 +364,8 @@ let optimization_options = [
   option_ftailcalls; option_fconstprop; option_fcse; option_fredundancy
 ]
 
-let set_all opts = List.iter (fun r -> r := true) opts
-let unset_all opts = List.iter (fun r -> r := false) opts
+let set_all opts () = List.iter (fun r -> r := true) opts
+let unset_all opts () = List.iter (fun r -> r := false) opts
 
 let num_source_files = ref 0
 
@@ -374,13 +374,16 @@ let num_input_files = ref 0
 let cmdline_actions =
   let f_opt name ref =
     [Exact("-f" ^ name), Set ref; Exact("-fno-" ^ name), Unset ref] in
+  let dwarf_version version () =
+    option_g:=true;
+    option_gdwarf := version in
   [
 (* Getting help *)
-  Exact "-help", Self print_usage_and_exit;
-  Exact "--help", Self print_usage_and_exit;
+  Exact "-help", Unit print_usage_and_exit;
+  Exact "--help", Unit print_usage_and_exit;
 (* Getting version info *)
-  Exact "-version", Self print_version_and_exit;
-  Exact "--version", Self print_version_and_exit;
+  Exact "-version", Unit print_version_and_exit;
+  Exact "--version", Unit print_version_and_exit;
 (* Processing options *)
   Exact "-c", Set option_c;
   Exact "-E", Set option_E;
@@ -391,17 +394,15 @@ let cmdline_actions =
   (* Preprocessing options *)
     @ prepro_actions @
 (* Language support options -- more below *)
- [ Exact "-fall", Self (fun _ -> set_all language_support_options);
-  Exact "-fnone", Self (fun _ -> unset_all language_support_options);
+ [ Exact "-fall", Unit (set_all language_support_options);
+  Exact "-fnone", Unit (unset_all language_support_options);
 (* Debugging options *)
-  Exact "-g", Self (fun s -> option_g := true;
-    option_gdwarf := 3);] @
+  Exact "-g", Unit (dwarf_version 3);] @
   (if gnu_system then
- [ Exact "-gdwarf-2", Self (fun s -> option_g:=true;
-    option_gdwarf := 2);
-  Exact "-gdwarf-3", Self (fun s -> option_g := true;
-    option_gdwarf := 3);] else []) @
- [ Exact "-frename-static", Self (fun s -> option_rename_static:= true);
+    [ Exact "-gdwarf-2", Unit (dwarf_version 2);
+      Exact "-gdwarf-3", Unit (dwarf_version 3);]
+  else []) @
+ [ Exact "-frename-static", Set option_rename_static;
    Exact "-gdepth", Integer (fun n -> if n = 0 || n <0 then begin
      option_g := false
    end else begin
@@ -409,9 +410,9 @@ let cmdline_actions =
      option_gdepth := if n > 3 then 3 else n
    end);
 (* Code generation options -- more below *)
-  Exact "-O0", Self (fun _ -> unset_all optimization_options);
-  Exact "-O", Self (fun _ -> set_all optimization_options);
-  _Regexp "-O[123]$", Self (fun _ -> set_all optimization_options);
+  Exact "-O0", Unit (unset_all optimization_options);
+  Exact "-O", Unit (set_all optimization_options);
+  _Regexp "-O[123]$", Unit (set_all optimization_options);
   Exact "-Os", Set option_Osize;
   Exact "-fsmall-data", Integer(fun n -> option_small_data := n);
   Exact "-fsmall-const", Integer(fun n -> option_small_const := n);
@@ -420,8 +421,8 @@ let cmdline_actions =
   Exact "-falign-branch-targets", Integer(fun n -> option_falignbranchtargets := n);
   Exact "-falign-cond-branches", Integer(fun n -> option_faligncondbranchs := n);
 (* Target processor options *)
-  Exact "-conf", String (fun _ -> ()); (* Ignore option since it is already handled *)
-  Exact "-target", String (fun _ -> ());] @ (* Ignore option since it is already handled *)
+  Exact "-conf", Ignore; (* Ignore option since it is already handled *)
+  Exact "-target", Ignore;] @ (* Ignore option since it is already handled *)
   (if Configuration.arch = "arm" then
     [ Exact "-mthumb", Set option_mthumb;
       Exact "-marm", Unset option_mthumb; ]
@@ -452,10 +453,10 @@ let cmdline_actions =
   Cerrors.warning_options @
 (* Interpreter mode *)
  [ Exact "-interp", Set option_interp;
-  Exact "-quiet", Self (fun _ -> Interp.trace := 0);
-  Exact "-trace", Self (fun _ -> Interp.trace := 2);
-  Exact "-random", Self (fun _ -> Interp.mode := Interp.Random);
-  Exact "-all", Self (fun _ -> Interp.mode := Interp.All)
+  Exact "-quiet", Unit (fun () -> Interp.trace := 0);
+  Exact "-trace", Unit (fun () -> Interp.trace := 2);
+  Exact "-random", Unit (fun () -> Interp.mode := Interp.Random);
+  Exact "-all", Unit (fun () -> Interp.mode := Interp.All)
  ]
 (* -f options: come in -f and -fno- variants *)
 (* Language support options *)
diff --git a/exportclight/Clightgen.ml b/exportclight/Clightgen.ml
index 0a586acd..bdbf8be9 100644
--- a/exportclight/Clightgen.ml
+++ b/exportclight/Clightgen.ml
@@ -98,10 +98,10 @@ Tracing options:\n\
 General options:\n\
 \  -v             Print external commands before invoking them\n"
 
-let print_usage_and_exit _ =
+let print_usage_and_exit () =
   printf "%s" usage_string; exit 0
 
-let print_version_and_exit _ =
+let print_version_and_exit () =
   printf "%s" version_string; exit 0
 
 let language_support_options = [
@@ -110,26 +110,26 @@ let language_support_options = [
   option_fpacked_structs; option_finline_asm
 ]
 
-let set_all opts = List.iter (fun r -> r := true) opts
-let unset_all opts = List.iter (fun r -> r := false) opts
+let set_all opts () = List.iter (fun r -> r := true) opts
+let unset_all opts () = List.iter (fun r -> r := false) opts
 
 let cmdline_actions =
   let f_opt name ref =
     [Exact("-f" ^ name), Set ref; Exact("-fno-" ^ name), Unset ref] in
   [
 (* Getting help *)
-  Exact "-help", Self print_usage_and_exit;
-  Exact "--help", Self print_usage_and_exit;
+  Exact "-help", Unit print_usage_and_exit;
+  Exact "--help", Unit print_usage_and_exit;
 (* Getting version info *)
-  Exact "-version", Self print_version_and_exit;
-  Exact "--version", Self print_version_and_exit;
+  Exact "-version", Unit print_version_and_exit;
+  Exact "--version", Unit print_version_and_exit;
 (* Processing options *)
   Exact "-E", Set option_E;]
 (* Preprocessing options *)
   @ prepro_actions @
 (* Language support options -- more below *)
-  [Exact "-fall", Self (fun _ -> set_all language_support_options);
-  Exact "-fnone", Self (fun _ -> unset_all language_support_options);
+  [Exact "-fall", Unit (set_all language_support_options);
+  Exact "-fnone", Unit (unset_all language_support_options);
 (* Tracing options *)
   Exact "-dparse", Set option_dparse;
   Exact "-dc", Set option_dcmedium;