diff options
| -rw-r--r-- | gcc/ada/errout.adb | 54 | ||||
| -rw-r--r-- | gcc/ada/erroutc.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/erroutc.ads | 60 |
3 files changed, 146 insertions, 13 deletions
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 2b4f278..f7eb8cd 100644 --- 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 index d7ca221..faef53a 100644 --- 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 index eb43466..62ce0d6 100644 --- 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 -- ----------------- |