From 8a740c6d441afd980e3bdb43d1844bd23e0ad55b Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 5 Aug 2016 17:48:53 +0200 Subject: 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 --- cparser/Cerrors.ml | 35 ++++++++++++-------------- cparser/Cerrors.mli | 63 ++++++++++++++++++++++++++++++++--------------- driver/Commandline.ml | 4 +++ driver/Commandline.mli | 2 ++ driver/Driver.ml | 53 ++++++++++++++++++++------------------- exportclight/Clightgen.ml | 20 +++++++-------- 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 "@[%d error%s detected.@]@." !num_errors (if !num_errors = 1 then "" else "s"); - if !warn_error && !num_warnings > 0 then - eprintf "@[%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 Enable the specific \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; -- cgit