Add the possibility for a tool to enable colored output using SGR when
outputting to a terminal. This is currently used only in GNATprove, but
could be enabled for compiler messages in the future. Use the same colors
(including bold) as gcc/g++ as much as possible.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* errout.adb (Output_Messages): Insert SGR strings where needed.
* erroutc.adb (Output_Message_Txt): Insert SGR strings where
needed in the text of the message itself.
(Output_Msg_Text): Allow for style message not to start
with (style).
* erroutc.ads: Add new constants and functions to control colors
in messages output to the terminal. Add variable Use_SGR_Control
that should be set to True for using SGR color control strings.diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -2071,7 +2071,9 @@ package body Errout is
procedure Write_Max_Errors;
-- Write message if max errors reached
- procedure Write_Source_Code_Lines (Span : Source_Span);
+ procedure Write_Source_Code_Lines
+ (Span : Source_Span;
+ SGR_Span : String);
-- Write the source code line corresponding to Span, as follows when
-- Span in on one line:
--
@@ -2095,6 +2097,9 @@ package body Errout is
-- | ^ here
--
-- where the caret on the line points to location Span.Ptr
+ --
+ -- SGR_Span is the SGR string to start the section of code in the span,
+ -- that should be closed with SGR_Reset.
-------------------------
-- Write_Error_Summary --
@@ -2290,8 +2295,10 @@ package body Errout is
-- Write_Source_Code_Lines --
-----------------------------
- procedure Write_Source_Code_Lines (Span : Source_Span) is
-
+ procedure Write_Source_Code_Lines
+ (Span : Source_Span;
+ SGR_Span : String)
+ is
function Get_Line_End
(Buf : Source_Buffer_Ptr;
Loc : Source_Ptr) return Source_Ptr;
@@ -2490,6 +2497,15 @@ package body Errout is
-- the gap with first/last lines, otherwise use ... to denote
-- intermediate lines.
+ -- If the span is on one line and not a simple source location,
+ -- color it appropriately.
+
+ if Line_Fst = Line_Lst
+ and then Col_Fst /= Col_Lst
+ then
+ Write_Str (SGR_Span);
+ end if;
+
declare
function Do_Write_Line (Cur_Line : Pos) return Boolean is
(Cur_Line in Line_Fst | Line | Line_Lst
@@ -2499,7 +2515,7 @@ package body Errout is
(Cur_Line = Line + 1 and then Cur_Line = Line_Lst - 1));
begin
while Cur_Loc <= Buf'Last
- and then Cur_Loc < Lst
+ and then Cur_Loc <= Lst
loop
if Do_Write_Line (Cur_Line) then
Write_Buffer_Char (Buf, Cur_Loc);
@@ -2535,6 +2551,12 @@ package body Errout is
end loop;
end;
+ if Line_Fst = Line_Lst
+ and then Col_Fst /= Col_Lst
+ then
+ Write_Str (SGR_Reset);
+ end if;
+
-- Output the rest of the last line of the span
Write_Buffer (Buf, Cur_Loc, Get_Line_End (Buf, Cur_Loc));
@@ -2546,6 +2568,9 @@ package body Errout is
Write_Str (String'(1 .. Width => ' '));
Write_Str (" |");
Write_Str (String'(1 .. Col_Fst - 1 => ' '));
+
+ Write_Str (SGR_Span);
+
Write_Str (String'(Col_Fst .. Col - 1 => '~'));
Write_Str ("^");
Write_Str (String'(Col + 1 .. Col_Lst => '~'));
@@ -2557,6 +2582,8 @@ package body Errout is
Write_Str (" here");
end if;
+ Write_Str (SGR_Reset);
+
Write_Eol;
end if;
end if;
@@ -2615,6 +2642,8 @@ package body Errout is
end if;
if Use_Prefix then
+ Write_Str (SGR_Locus);
+
if Full_Path_Name_For_Brief_Errors then
Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
else
@@ -2633,6 +2662,8 @@ package body Errout is
Write_Int (Int (Errors.Table (E).Col));
Write_Str (": ");
+
+ Write_Str (SGR_Reset);
end if;
Output_Msg_Text (E);
@@ -2652,12 +2683,23 @@ package body Errout is
Errors.Table (E).Insertion_Sloc;
begin
if Loc /= No_Location then
- Write_Source_Code_Lines (To_Span (Loc));
+ Write_Source_Code_Lines
+ (To_Span (Loc), SGR_Span => SGR_Note);
end if;
end;
else
- Write_Source_Code_Lines (Errors.Table (E).Sptr);
+ declare
+ SGR_Span : constant String :=
+ (if Errors.Table (E).Info then SGR_Note
+ elsif Errors.Table (E).Warn
+ and then not Errors.Table (E).Warn_Err
+ then SGR_Warning
+ else SGR_Error);
+ begin
+ Write_Source_Code_Lines
+ (Errors.Table (E).Sptr, SGR_Span);
+ end;
end if;
end if;
end if;
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -699,7 +699,7 @@ package body Erroutc is
-- For info messages, prefix message with "info: "
elsif E_Msg.Info then
- Txt := new String'("info: " & Txt.all);
+ Txt := new String'(SGR_Note & "info: " & SGR_Reset & Txt.all);
-- Warning treated as error
@@ -709,27 +709,58 @@ package body Erroutc is
-- [warning-as-error] at the end.
Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
- Txt := new String'("error: " & Txt.all & " [warning-as-error]");
+ Txt := new String'(SGR_Error & "error: " & SGR_Reset
+ & Txt.all & " [warning-as-error]");
-- Normal warning, prefix with "warning: "
elsif E_Msg.Warn then
- Txt := new String'("warning: " & Txt.all);
+ Txt := new String'(SGR_Warning & "warning: " & SGR_Reset & Txt.all);
- -- No prefix needed for style message, "(style)" is there already
+ -- No prefix needed for style message, "(style)" is there already,
+ -- although not necessarily in first position if -gnatdJ is used.
elsif E_Msg.Style then
- null;
+ if Txt (Txt'First .. Txt'First + 6) = "(style)" then
+ Txt := new String'(SGR_Warning & "(style)" & SGR_Reset
+ & Txt (Txt'First + 7 .. Txt'Last));
+ end if;
-- No prefix needed for check message, severity is there already
elsif E_Msg.Check then
- null;
+
+ -- The message format is "severity: ..."
+ --
+ -- Enclose the severity with an SGR control string if requested
+
+ if Use_SGR_Control then
+ declare
+ Msg : String renames Text.all;
+ Colon : Natural := 0;
+ begin
+ -- Find first colon
+
+ for J in Msg'Range loop
+ if Msg (J) = ':' then
+ Colon := J;
+ exit;
+ end if;
+ end loop;
+
+ pragma Assert (Colon > 0);
+
+ Txt := new String'(SGR_Error
+ & Msg (Msg'First .. Colon)
+ & SGR_Reset
+ & Msg (Colon + 1 .. Msg'Last));
+ end;
+ end if;
-- All other cases, add "error: " if unique error tag set
elsif Opt.Unique_Error_Tag then
- Txt := new String'("error: " & Txt.all);
+ Txt := new String'(SGR_Error & "error: " & SGR_Reset & Txt.all);
end if;
-- Set error message line length and length of message
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -390,6 +390,66 @@ package Erroutc is
-- find such an On entry, we cancel the indication of it being the
-- configuration case. This seems to handle all cases we run into ok.
+ -------------------
+ -- Color Control --
+ -------------------
+
+ Use_SGR_Control : Boolean := False;
+ -- Set to True for enabling colored output. This should only be done when
+ -- outputting messages to a terminal that supports it.
+
+ -- Colors in messages output to a terminal are controlled using SGR
+ -- (Select Graphic Rendition).
+
+ Color_Separator : constant String := ";";
+ Color_None : constant String := "00";
+ Color_Bold : constant String := "01";
+ Color_Underscore : constant String := "04";
+ Color_Blink : constant String := "05";
+ Color_Reverse : constant String := "07";
+ Color_Fg_Black : constant String := "30";
+ Color_Fg_Red : constant String := "31";
+ Color_Fg_Green : constant String := "32";
+ Color_Fg_Yellow : constant String := "33";
+ Color_Fg_Blue : constant String := "34";
+ Color_Fg_Magenta : constant String := "35";
+ Color_Fg_Cyan : constant String := "36";
+ Color_Fg_White : constant String := "37";
+ Color_Bg_Black : constant String := "40";
+ Color_Bg_Red : constant String := "41";
+ Color_Bg_Green : constant String := "42";
+ Color_Bg_Yellow : constant String := "43";
+ Color_Bg_Blue : constant String := "44";
+ Color_Bg_Magenta : constant String := "45";
+ Color_Bg_Cyan : constant String := "46";
+ Color_Bg_White : constant String := "47";
+
+ SGR_Start : constant String := ASCII.ESC & "[";
+ SGR_End : constant String := "m" & ASCII.ESC & "[K";
+
+ function SGR_Seq (Str : String) return String is
+ (if Use_SGR_Control then SGR_Start & Str & SGR_End else "");
+ -- Return the SGR control string for the commands in Str. It returns the
+ -- empty string if Use_SGR_Control is False, so that we can insert this
+ -- string unconditionally.
+
+ function SGR_Reset return String is (SGR_Seq (""));
+ -- This ends the current section of colored output
+
+ -- We're using the same colors as gcc/g++ for errors/warnings/notes/locus.
+ -- More colors are defined in gcc/g++ for other features of diagnostic
+ -- messages (e.g. inline types, fixit) and could be used in GNAT in the
+ -- future. The following functions start a section of colored output.
+
+ function SGR_Error return String is
+ (SGR_Seq (Color_Bold & Color_Separator & Color_Fg_Red));
+ function SGR_Warning return String is
+ (SGR_Seq (Color_Bold & Color_Separator & Color_Fg_Magenta));
+ function SGR_Note return String is
+ (SGR_Seq (Color_Bold & Color_Separator & Color_Fg_Cyan));
+ function SGR_Locus return String is
+ (SGR_Seq (Color_Bold));
+
-----------------
-- Subprograms --
-----------------
