------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E R R O U T C . P R E T T Y _ E M I T T E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2025, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Opt; use Opt; with Output; use Output; with Sinput; use Sinput; with GNAT.Lists; use GNAT.Lists; package body Erroutc.Pretty_Emitter is REGION_OFFSET : constant := 1; -- Number of characters between the line bar and the region span REGION_ARM_SIZE : constant := 2; -- Number of characters on the region span arms -- e.g. two for this case: -- +-- -- | -- +-- -- ^^ REGION_SIZE : constant := REGION_OFFSET + 1 + REGION_ARM_SIZE; -- The total number of characters taken up by the region span characters MAX_BAR_POS : constant := 7; -- The maximum position of the line bar from the start of the line procedure Destroy (Elem : in out Labeled_Span_Type); pragma Inline (Destroy); procedure Destroy (Elem : in out Labeled_Span_Type) is begin -- Diagnostic elements will be freed when all the diagnostics have been -- emitted. null; end Destroy; package Labeled_Span_Lists is new Doubly_Linked_Lists (Element_Type => Labeled_Span_Type, "=" => "=", Destroy_Element => Destroy, Check_Tampering => False); subtype Labeled_Span_List is Labeled_Span_Lists.Doubly_Linked_List; type Printable_Line is record First : Source_Ptr; -- The first character of the line Last : Source_Ptr; -- The last character of the line Line_Nr : Pos; -- The line number Spans : Labeled_Span_List; -- The spans applied on the line end record; procedure Destroy (Elem : in out Printable_Line); pragma Inline (Destroy); function Equals (L, R : Printable_Line) return Boolean is (L.Line_Nr = R.Line_Nr); package Lines_Lists is new Doubly_Linked_Lists (Element_Type => Printable_Line, "=" => Equals, Destroy_Element => Destroy, Check_Tampering => False); subtype Lines_List is Lines_Lists.Doubly_Linked_List; type File_Sections is record File : String_Ptr; -- Name of the file Ptr : Source_Ptr; -- Pointer to the Primary location in the file section that is printed -- at the start of the file section. If there are none then the first -- location in the section. Lines : Lines_List; -- Lines to be printed for the file end record; procedure Destroy (Elem : in out File_Sections); pragma Inline (Destroy); function Equals (L, R : File_Sections) return Boolean is (L.File /= null and then R.File /= null and then L.File.all = R.File.all); package File_Section_Lists is new Doubly_Linked_Lists (Element_Type => File_Sections, "=" => Equals, Destroy_Element => Destroy, Check_Tampering => False); subtype File_Section_List is File_Section_Lists.Doubly_Linked_List; function Create_File_Sections (Locations : Labeled_Span_Id) return File_Section_List; -- Create a list of file sections from the labeled spans that are to be -- printed. -- -- Each file section contains a list of lines that are to be printed for -- the file and the spans that are applied to each of those lines. procedure Create_File_Section (Sections : in out File_Section_List; Loc : Labeled_Span_Type); -- Create a new file section for the given labeled span. procedure Add_Printable_Line (Lines : Lines_List; Loc : Labeled_Span_Type; S_Ptr : Source_Ptr); procedure Create_Printable_Line (Lines : Lines_List; Loc : Labeled_Span_Type; S_Ptr : Source_Ptr); -- Create a new printable line for the given labeled span and add it in the -- correct position to the Lines list based on the line number. function Get_Region_Span (Spans : Labeled_Span_List) return Labeled_Span_Type; function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean; procedure Write_Region_Delimiter (SGR_Code : String); -- Write the arms signifying the start and end of a region span -- e.g. +-- procedure Write_Region_Bar (SGR_Code : String); -- Write the bar signifying the continuation of a region span -- e.g. | procedure Write_Region_Continuation (SGR_Code : String); -- Write the continuation signifying the continuation of a region span -- e.g. : procedure Write_Region_Offset; -- Write a number of whitespaces equal to the size of the region span function Trimmed_Image (I : Natural) return String; -- Removes the leading whitespace from the 'Image of a Natural number. procedure Write_Span_Labels (Loc : Labeled_Span_Type; L : Printable_Line; Line_Size : Integer; Idx : String; Within_Region_Span : Boolean; SGR_Code : String; Region_Span_SGR_Code : String); procedure Write_File_Section (Sec : File_Sections; Write_File_Name : Boolean; File_Name_Offset : Integer; Include_Spans : Boolean; SGR_Code : String := SGR_Note); -- Prints the labled spans for a given File_Section. -- -- --> -- procedure Write_Labeled_Spans (Locations : Labeled_Span_Id; Write_File_Name : Boolean; File_Name_Offset : Integer; Include_Spans : Boolean := True; SGR_Code : String := SGR_Note); -- Pretty-prints all of the code regions indicated by the Locations. The -- labeled spans in the Locations are grouped by file into File_Sections -- and sorted by the file name of the Primary location followed by all -- other locations sorted alphabetically. procedure Write_Intersecting_Labels (Intersecting_Labels : Labeled_Span_List; SGR_Code : String); -- Prints the indices and their associated labels of intersecting labels. -- -- Labeled spans that are insercting on the same line are printed without -- labels. Instead the span pointer is replaced by an index number and in -- the end all of the indices are printed with their associated labels. -- -- -- 42 | [for I in V1.First_Index .. V1.Last_Index => V1(I), -6]; -- | ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- | 1- -- | 2------------------------------------------- -- | 1: positional element -- | 2: named element function Get_Line_End (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; -- Get the source location for the end of the line (LF) in Buf for Loc. If -- Loc is past the end of Buf already, return Buf'Last. function Get_Line_Start (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; -- Get the source location for the start of the line in Buf for Loc function Get_First_Line_Char (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; -- Get first non-space character in the line containing Loc function Get_Last_Line_Char (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; -- Get last non line end [LF, CR] character in the line containing Loc function Image (X : Positive; Width : Positive) return String; -- Output number X over Width characters, with whitespace padding. -- Only output the low-order Width digits of X, if X is larger than -- Width digits. procedure Write_Buffer (Buf : Source_Buffer_Ptr; First : Source_Ptr; Last : Source_Ptr); -- Output the characters from First to Last position in Buf, using -- Write_Buffer_Char. procedure Write_Buffer_Char (Buf : Source_Buffer_Ptr; Loc : Source_Ptr); -- Output the characters at position Loc in Buf, translating ASCII.HT -- in a suitable number of spaces so that the output is not modified -- by starting in a different column that 1. procedure Write_Line_Marker (Num : Pos; Width : Positive); -- Attempts to write the line number within Width number of whitespaces -- followed by a bar ':' symbol. -- -- e.g ' 12 |' -- -- This is usually used on source code lines that are marked by a span. procedure Write_Empty_Bar_Line (Width : Integer); -- Writes Width number of whitespaces and a bar '|' symbol. -- -- e.g ' |' -- -- This is usually used on lines where the label is going to printed. procedure Write_Empty_Skip_Line (Width : Integer); -- Writes Width number of whitespaces and a bar ':' symbol. -- -- e.g ' :' -- -- This is usually used between non-continous source lines that neec to be -- printed. procedure Write_Error_Msg_Line (E_Msg : Error_Msg_Object); -- Write the error message line for the given diagnostic: -- -- '['']' : ['['']'] function Should_Write_File_Name (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean; -- If the sub-diagnostic and the main diagnostic only point to the same -- file then there is no reason to add the file name to the sub-diagnostic. function Should_Write_Spans (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean; -- Old sub-diagnostics used to have the same location as the main -- diagnostic in order to group them correctly. However in most cases -- it was not meant to point to a location but rather add an additional -- message to the original diagnostic. -- -- If the sub-diagnostic and the main diagnostic have the same location -- then we should avoid printing the spans. procedure Print_Diagnostic (E : Error_Msg_Id); -- Entry point for printing a primary diagnostic message. procedure Print_Edit (Edit : Edit_Type; Offset : Integer); -- Prints an edit object as follows: -- -- --> -- - -- + procedure Print_Fix (Fix : Fix_Type; Offset : Integer); -- Prints a fix object as follows -- -- + Fix: -- procedure Print_Sub_Diagnostic (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object; Offset : Integer); function To_String (Sptr : Source_Ptr) return String; -- Convert the source pointer to a string of the form: "file:line:column" function To_File_Name (Sptr : Source_Ptr) return String; -- Converts the file name of the Sptr to a string. function Line_To_String (Sptr : Source_Ptr) return String; -- Converts the logical line number of the Sptr to a string. function Column_To_String (Sptr : Source_Ptr) return String; -- Converts the column number of the Sptr to a string. Column values less -- than 10 are prefixed with a 0. ------------- -- Destroy -- ------------- procedure Destroy (Elem : in out Printable_Line) is begin Labeled_Span_Lists.Destroy (Elem.Spans); end Destroy; ------------- -- Destroy -- ------------- procedure Destroy (Elem : in out File_Sections) is begin Free (Elem.File); Lines_Lists.Destroy (Elem.Lines); end Destroy; ------------------ -- Get_Line_End -- ------------------ function Get_Line_End (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr is Cur_Loc : Source_Ptr := Source_Ptr'Min (Loc, Buf'Last); begin while Cur_Loc < Buf'Last and then Buf (Cur_Loc) /= ASCII.LF loop Cur_Loc := Cur_Loc + 1; end loop; return Cur_Loc; end Get_Line_End; -------------------- -- Get_Line_Start -- -------------------- function Get_Line_Start (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr is Cur_Loc : Source_Ptr := Loc; begin while Cur_Loc > Buf'First and then Buf (Cur_Loc - 1) /= ASCII.LF loop Cur_Loc := Cur_Loc - 1; end loop; return Cur_Loc; end Get_Line_Start; ------------------------- -- Get_First_Line_Char -- ------------------------- function Get_First_Line_Char (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr is Cur_Loc : Source_Ptr := Get_Line_Start (Buf, Loc); begin while Cur_Loc < Buf'Last and then Buf (Cur_Loc) = ' ' loop Cur_Loc := Cur_Loc + 1; end loop; return Cur_Loc; end Get_First_Line_Char; ------------------------ -- Get_Last_Line_Char -- ------------------------ function Get_Last_Line_Char (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr is Cur_Loc : Source_Ptr := Get_Line_End (Buf, Loc); begin while Cur_Loc > Buf'First and then Buf (Cur_Loc) in ASCII.LF | ASCII.CR loop Cur_Loc := Cur_Loc - 1; end loop; return Cur_Loc; end Get_Last_Line_Char; ----------- -- Image -- ----------- function Image (X : Positive; Width : Positive) return String is Str : String (1 .. Width); Curr : Natural := X; begin for J in reverse 1 .. Width loop if Curr > 0 then Str (J) := Character'Val (Character'Pos ('0') + Curr mod 10); Curr := Curr / 10; else Str (J) := ' '; end if; end loop; return Str; end Image; -------------------------------- -- Has_Multiple_Labeled_Spans -- -------------------------------- function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean is Count : Natural := 0; Loc : Labeled_Span_Type; Loc_It : Labeled_Span_Lists.Iterator := Labeled_Span_Lists.Iterate (L.Spans); begin while Labeled_Span_Lists.Has_Next (Loc_It) loop Labeled_Span_Lists.Next (Loc_It, Loc); if Loc.Label /= null then Count := Count + 1; end if; end loop; return Count > 1; end Has_Multiple_Labeled_Spans; --------------------- -- Get_Region_Span -- --------------------- function Get_Region_Span (Spans : Labeled_Span_List) return Labeled_Span_Type is Loc : Labeled_Span_Type; Loc_It : Labeled_Span_Lists.Iterator := Labeled_Span_Lists.Iterate (Spans); begin while Labeled_Span_Lists.Has_Next (Loc_It) loop Labeled_Span_Lists.Next (Loc_It, Loc); if Loc.Is_Region then return Loc; end if; end loop; return No_Labeled_Span_Object; end Get_Region_Span; ------------------ -- Write_Buffer -- ------------------ procedure Write_Buffer (Buf : Source_Buffer_Ptr; First : Source_Ptr; Last : Source_Ptr) is begin for Loc in First .. Last loop Write_Buffer_Char (Buf, Loc); end loop; end Write_Buffer; ----------------------- -- Write_Buffer_Char -- ----------------------- procedure Write_Buffer_Char (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) is begin -- If the character ASCII.HT is not the last one in the file, -- output as many spaces as the character represents in the -- original source file. if Buf (Loc) = ASCII.HT and then Loc < Buf'Last then for X in Get_Column_Number (Loc) .. Get_Column_Number (Loc + 1) - 1 loop Write_Char (' '); end loop; -- Otherwise output the character itself else Write_Char (Buf (Loc)); end if; end Write_Buffer_Char; ----------------------- -- Write_Line_Marker -- ----------------------- procedure Write_Line_Marker (Num : Pos; Width : Positive) is begin Write_Str (Image (Positive (Num), Width => Width - 2)); Write_Str (" |"); end Write_Line_Marker; -------------------------- -- Write_Empty_Bar_Line -- -------------------------- procedure Write_Empty_Bar_Line (Width : Integer) is begin Write_Str (String'(1 .. Width - 1 => ' ')); Write_Str ("|"); end Write_Empty_Bar_Line; --------------------------- -- Write_Empty_Skip_Line -- --------------------------- procedure Write_Empty_Skip_Line (Width : Integer) is begin Write_Str (String'(1 .. Width - 1 => ' ')); Write_Str (":"); end Write_Empty_Skip_Line; ---------------------------- -- Write_Region_Delimiter -- ---------------------------- procedure Write_Region_Delimiter (SGR_Code : String) is begin Write_Str (String'(1 .. REGION_OFFSET => ' ')); Write_Str (SGR_Code); Write_Str ("+"); Write_Str (String'(1 .. REGION_ARM_SIZE => '-')); Write_Str (SGR_Reset); end Write_Region_Delimiter; ---------------------- -- Write_Region_Bar -- ---------------------- procedure Write_Region_Bar (SGR_Code : String) is begin Write_Str (String'(1 .. REGION_OFFSET => ' ')); Write_Str (SGR_Code); Write_Str ("|"); Write_Str (SGR_Reset); Write_Str (String'(1 .. REGION_ARM_SIZE => ' ')); end Write_Region_Bar; ------------------------------- -- Write_Region_Continuation -- ------------------------------- procedure Write_Region_Continuation (SGR_Code : String) is begin Write_Str (String'(1 .. REGION_OFFSET => ' ')); Write_Str (SGR_Code); Write_Str (":"); Write_Str (SGR_Reset); Write_Str (String'(1 .. REGION_ARM_SIZE => ' ')); end Write_Region_Continuation; ------------------------- -- Write_Region_Offset -- ------------------------- procedure Write_Region_Offset is begin Write_Str (String'(1 .. REGION_SIZE => ' ')); end Write_Region_Offset; ------------------------ -- Add_Printable_Line -- ------------------------ procedure Add_Printable_Line (Lines : Lines_List; Loc : Labeled_Span_Type; S_Ptr : Source_Ptr) is L : Printable_Line; L_It : Lines_Lists.Iterator; Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr)); Line_Found : Boolean := False; begin L_It := Lines_Lists.Iterate (Lines); while Lines_Lists.Has_Next (L_It) loop Lines_Lists.Next (L_It, L); if not Line_Found and then L.Line_Nr = Line_Ptr then if not Labeled_Span_Lists.Contains (L.Spans, Loc) then Labeled_Span_Lists.Append (L.Spans, Loc); end if; Line_Found := True; end if; end loop; if not Line_Found then Create_Printable_Line (Lines, Loc, S_Ptr); end if; end Add_Printable_Line; --------------------------- -- Create_Printable_Line -- --------------------------- procedure Create_Printable_Line (Lines : Lines_List; Loc : Labeled_Span_Type; S_Ptr : Source_Ptr) is Spans : constant Labeled_Span_List := Labeled_Span_Lists.Create; Buf : constant Source_Buffer_Ptr := Source_Text (Get_Source_File_Index (S_Ptr)); Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr)); New_Line : constant Printable_Line := (First => Get_Line_Start (Buf, S_Ptr), Last => Get_Line_End (Buf, S_Ptr), Line_Nr => Line_Nr, Spans => Spans); L : Printable_Line; L_It : Lines_Lists.Iterator := Lines_Lists.Iterate (Lines); Found_Greater_Line : Boolean := False; Insert_Before_Line : Printable_Line; begin Labeled_Span_Lists.Append (Spans, Loc); -- Insert the new line based on the line number while Lines_Lists.Has_Next (L_It) loop Lines_Lists.Next (L_It, L); if not Found_Greater_Line and then L.Line_Nr > New_Line.Line_Nr then Found_Greater_Line := True; Insert_Before_Line := L; Lines_Lists.Insert_Before (Lines, Insert_Before_Line, New_Line); end if; end loop; -- Insert after all the lines have been iterated over to avoid the -- mutation lock in GNAT.Lists. if not Found_Greater_Line then Lines_Lists.Append (Lines, New_Line); end if; end Create_Printable_Line; ------------------------- -- Create_File_Section -- ------------------------- procedure Create_File_Section (Sections : in out File_Section_List; Loc : Labeled_Span_Type) is Lines : constant Lines_List := Lines_Lists.Create; -- Carret positions Ptr : constant Source_Ptr := Loc.Span.Ptr; Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (Ptr)); -- Span start positions Fst : constant Source_Ptr := Loc.Span.First; Line_Fst : constant Pos := Pos (Get_Physical_Line_Number (Fst)); -- Span end positions Lst : constant Source_Ptr := Loc.Span.Last; Line_Lst : constant Pos := Pos (Get_Physical_Line_Number (Lst)); begin Create_Printable_Line (Lines, Loc, Fst); if Line_Fst /= Line_Ptr then Create_Printable_Line (Lines, Loc, Ptr); end if; if Line_Ptr /= Line_Lst then Create_Printable_Line (Lines, Loc, Lst); end if; File_Section_Lists.Append (Sections, (File => new String'(To_File_Name (Loc.Span.Ptr)), Ptr => Loc.Span.Ptr, Lines => Lines)); end Create_File_Section; -------------------------- -- Create_File_Sections -- -------------------------- function Create_File_Sections (Locations : Labeled_Span_Id) return File_Section_List is Loc : Labeled_Span_Type; Loc_It : Labeled_Span_Id := Locations; Sections : File_Section_List := File_Section_Lists.Create; Sec : File_Sections; F_It : File_Section_Lists.Iterator; File_Found : Boolean; begin while Loc_It /= No_Labeled_Span loop Loc := Erroutc.Locations.Table (Loc_It); File_Found := False; F_It := File_Section_Lists.Iterate (Sections); while File_Section_Lists.Has_Next (F_It) loop File_Section_Lists.Next (F_It, Sec); if Sec.File /= null and then Sec.File.all = To_File_Name (Loc.Span.Ptr) then File_Found := True; Add_Printable_Line (Sec.Lines, Loc, Loc.Span.First); Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Ptr); Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Last); if Loc.Is_Primary then Sec.Ptr := Loc.Span.Ptr; end if; end if; end loop; if not File_Found then Create_File_Section (Sections, Loc); end if; Loc_It := Loc.Next; end loop; return Sections; end Create_File_Sections; ----------------------- -- Write_Span_Labels -- ----------------------- procedure Write_Span_Labels (Loc : Labeled_Span_Type; L : Printable_Line; Line_Size : Integer; Idx : String; Within_Region_Span : Boolean; SGR_Code : String; Region_Span_SGR_Code : String) is Span_Char : constant Character := (if Loc.Is_Primary then '~' else '-'); Buf : constant Source_Buffer_Ptr := Source_Text (Get_Source_File_Index (L.First)); Col_L_Fst : constant Natural := Natural (Get_Column_Number (Get_First_Line_Char (Buf, L.First))); Col_L_Lst : constant Natural := Natural (Get_Column_Number (Get_Last_Line_Char (Buf, L.Last))); -- Carret positions Ptr : constant Source_Ptr := Loc.Span.Ptr; Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (Ptr)); Col_Ptr : constant Natural := Natural (Get_Column_Number (Ptr)); -- Span start positions Fst : constant Source_Ptr := Loc.Span.First; Line_Fst : constant Pos := Pos (Get_Physical_Line_Number (Fst)); Col_Fst : constant Natural := Natural (Get_Column_Number (Fst)); -- Span end positions Lst : constant Source_Ptr := Loc.Span.Last; Line_Lst : constant Pos := Pos (Get_Physical_Line_Number (Lst)); Col_Lst : constant Natural := Natural (Get_Column_Number (Lst)); -- Attributes for the span on the current line Span_Sym : constant String := (if Idx = "" then "^" else Idx); Span_Fst : constant Natural := (if Line_Fst = L.Line_Nr then Col_Fst else Col_L_Fst); Span_Lst : constant Natural := (if Line_Lst = L.Line_Nr then Col_Lst else Col_L_Lst); Span_Ptr_Fst : constant Natural := (if Line_Ptr = L.Line_Nr then Col_Ptr else Col_L_Fst); Span_Ptr_Lst : constant Natural := (if Line_Ptr = L.Line_Nr then Span_Ptr_Fst + Span_Sym'Length else Span_Fst); begin if not Loc.Is_Region then Write_Empty_Bar_Line (Line_Size); if Within_Region_Span then Write_Region_Bar (Region_Span_SGR_Code); else Write_Region_Offset; end if; Write_Str (String'(1 .. Span_Fst - 1 => ' ')); Write_Str (SGR_Code); if Line_Ptr = L.Line_Nr then Write_Str (String'(Span_Fst .. Col_Ptr - 1 => Span_Char)); Write_Str (Span_Sym); end if; Write_Str (String'(Span_Ptr_Lst .. Span_Lst => Span_Char)); Write_Str (SGR_Reset); Write_Eol; -- Write the label under the line unless it is an intersecting span. -- In this case omit the label which will be printed later along with -- the index. if Loc.Label /= null and then Idx = "" then Write_Empty_Bar_Line (Line_Size); if Within_Region_Span then Write_Region_Bar (Region_Span_SGR_Code); else Write_Region_Offset; end if; Write_Str (String'(1 .. Span_Fst - 1 => ' ')); Write_Str (SGR_Code); Write_Str (Loc.Label.all); Write_Str (SGR_Reset); Write_Eol; end if; else if Line_Lst = L.Line_Nr then Write_Empty_Bar_Line (Line_Size); Write_Str (String'(1 .. REGION_OFFSET => ' ')); Write_Str (SGR_Code); Write_Str (Loc.Label.all); Write_Str (SGR_Reset); Write_Eol; end if; end if; end Write_Span_Labels; ------------------- -- Trimmed_Image -- ------------------- function Trimmed_Image (I : Natural) return String is Img_Raw : constant String := Natural'Image (I); begin return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); end Trimmed_Image; ------------------------------- -- Write_Intersecting_Labels -- ------------------------------- procedure Write_Intersecting_Labels (Intersecting_Labels : Labeled_Span_List; SGR_Code : String) is L : Labeled_Span_Type; L_It : Labeled_Span_Lists.Iterator := Labeled_Span_Lists.Iterate (Intersecting_Labels); Idx : Integer := 0; begin while Labeled_Span_Lists.Has_Next (L_It) loop Labeled_Span_Lists.Next (L_It, L); Idx := Idx + 1; Write_Empty_Bar_Line (MAX_BAR_POS); Write_Str (" "); Write_Str ((if L.Is_Primary then SGR_Code else SGR_Note)); Write_Int (Int (Idx)); Write_Str (": "); Write_Str (L.Label.all); Write_Str (SGR_Reset); Write_Eol; end loop; end Write_Intersecting_Labels; ------------------------ -- Write_File_Section -- ------------------------ procedure Write_File_Section (Sec : File_Sections; Write_File_Name : Boolean; File_Name_Offset : Integer; Include_Spans : Boolean; SGR_Code : String := SGR_Note) is use Lines_Lists; function Get_SGR_Code (L : Labeled_Span_Type) return String is (if L.Is_Primary then SGR_Code else SGR_Note); L : Printable_Line; L_It : Iterator := Iterate (Sec.Lines); Multiple_Labeled_Spans : Boolean := False; Idx : Integer := 0; Intersecting_Labels : constant Labeled_Span_List := Labeled_Span_Lists.Create; Prev_Line_Nr : Natural := 0; Within_Region_Span : Boolean := False; begin if Write_File_Name then -- offset the file start location for sub-diagnostics Write_Str (String'(1 .. File_Name_Offset => ' ')); Write_Str ("--> " & To_String (Sec.Ptr)); Write_Eol; end if; -- Historically SPARK does not include spans in their info messages. if not Include_Spans then return; end if; while Has_Next (L_It) loop Next (L_It, L); declare Line_Nr : constant Pos := L.Line_Nr; Line_Str : constant String := Trimmed_Image (Natural (Line_Nr)); Line_Size : constant Integer := Integer'Max (Line_Str'Length, MAX_BAR_POS); Loc : Labeled_Span_Type; Loc_It : Labeled_Span_Lists.Iterator := Labeled_Span_Lists.Iterate (L.Spans); Buf : constant Source_Buffer_Ptr := Source_Text (Get_Source_File_Index (L.First)); Region_Span : constant Labeled_Span_Type := Get_Region_Span (L.Spans); Contains_Region_Span_Start : constant Boolean := Region_Span /= No_Labeled_Span_Object and then Line_Nr = Pos (Get_Physical_Line_Number (Region_Span.Span.First)); Contains_Region_Span_End : constant Boolean := Region_Span /= No_Labeled_Span_Object and then Line_Nr = Pos (Get_Physical_Line_Number (Region_Span.Span.Last)); Region_Span_Color : constant String := (if Region_Span /= No_Labeled_Span_Object then Get_SGR_Code (Region_Span) else SGR_Note); begin if not Multiple_Labeled_Spans then Multiple_Labeled_Spans := Has_Multiple_Labeled_Spans (L); end if; -- Write an empty line with the continuation symbol if the line -- numbers are not contiguous if Prev_Line_Nr /= 0 and then Pos (Prev_Line_Nr + 1) /= Line_Nr then Write_Empty_Skip_Line (Line_Size); if Within_Region_Span then Write_Region_Continuation (Region_Span_Color); end if; Write_Eol; end if; if Contains_Region_Span_Start then Within_Region_Span := True; end if; Write_Line_Marker (Line_Nr, Line_Size); -- Write either the region span symbol or the same number of -- whitespaces. if Contains_Region_Span_Start or Contains_Region_Span_End then Write_Region_Delimiter (Region_Span_Color); elsif Within_Region_Span then Write_Region_Bar (Region_Span_Color); else Write_Region_Offset; end if; -- Write the line itself Write_Buffer (Buf => Buf, First => L.First, Last => L.Last); -- Write all the spans for the line while Labeled_Span_Lists.Has_Next (Loc_It) loop Labeled_Span_Lists.Next (Loc_It, Loc); if Multiple_Labeled_Spans and then Loc.Label /= null then -- Collect all the spans with labels to print them at the -- end. Labeled_Span_Lists.Append (Intersecting_Labels, Loc); Idx := Idx + 1; Write_Span_Labels (Loc => Loc, L => L, Line_Size => Line_Size, Idx => Trimmed_Image (Idx), Within_Region_Span => Within_Region_Span, SGR_Code => Get_SGR_Code (Loc), Region_Span_SGR_Code => Region_Span_Color); else Write_Span_Labels (Loc => Loc, L => L, Line_Size => Line_Size, Idx => "", Within_Region_Span => Within_Region_Span, SGR_Code => Get_SGR_Code (Loc), Region_Span_SGR_Code => Region_Span_Color); end if; end loop; if Contains_Region_Span_End then Within_Region_Span := False; end if; Prev_Line_Nr := Natural (Line_Nr); end; end loop; Write_Intersecting_Labels (Intersecting_Labels, SGR_Code); end Write_File_Section; ------------------------- -- Write_Labeled_Spans -- ------------------------- procedure Write_Labeled_Spans (Locations : Labeled_Span_Id; Write_File_Name : Boolean; File_Name_Offset : Integer; Include_Spans : Boolean := True; SGR_Code : String := SGR_Note) is Sections : File_Section_List := Create_File_Sections (Locations); Sec : File_Sections; F_It : File_Section_Lists.Iterator := File_Section_Lists.Iterate (Sections); begin while File_Section_Lists.Has_Next (F_It) loop File_Section_Lists.Next (F_It, Sec); Write_File_Section (Sec => Sec, Write_File_Name => Write_File_Name, File_Name_Offset => File_Name_Offset, Include_Spans => Include_Spans, SGR_Code => SGR_Code); end loop; File_Section_Lists.Destroy (Sections); end Write_Labeled_Spans; -------------------------- -- Write_Error_Msg_Line -- -------------------------- procedure Write_Error_Msg_Line (E_Msg : Error_Msg_Object) is Switch_Str : constant String := Get_Doc_Switch (E_Msg); SGR_Code : constant String := Get_SGR_Code (E_Msg); begin Write_Str (SGR_Code); if not GNATprove_Mode or else E_Msg.Id /= No_Diagnostic_Id then Write_Str ("[" & To_String (E_Msg.Id) & "]"); end if; Write_Str (" " & Kind_To_String (E_Msg) & ": "); Write_Str (SGR_Reset); Write_Str (E_Msg.Text.all); if Switch_Str /= "" then Write_Str (" " & Switch_Str); end if; if E_Msg.Warn_Err = From_Pragma then Write_Str (" " & Warn_As_Err_Tag); end if; Write_Eol; end Write_Error_Msg_Line; ---------------------------- -- Should_Write_File_Name -- ---------------------------- function Should_Write_File_Name (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean is Sub_Loc : constant Labeled_Span_Type := Locations.Table (Primary_Location (Sub_Diag)); Diag_Loc : constant Labeled_Span_Type := Locations.Table (Primary_Location (Diag)); function Has_Multiple_Files (Diag : Error_Msg_Object) return Boolean; ------------------------ -- Has_Multiple_Files -- ------------------------ function Has_Multiple_Files (Diag : Error_Msg_Object) return Boolean is First : constant Labeled_Span_Type := Locations.Table (Diag.Locations); File : constant String := To_File_Name (First.Span.Ptr); Loc_Id : Labeled_Span_Id := Diag.Locations; Loc : Labeled_Span_Type; begin Loc_Id := Diag.Locations; while Loc_Id /= No_Labeled_Span loop Loc := Locations.Table (Loc_Id); if To_File_Name (Loc.Span.Ptr) /= File then return True; end if; Loc_Id := Loc.Next; end loop; return False; end Has_Multiple_Files; -- Start of processing for Should_Write_File_Name begin return Has_Multiple_Files (Diag) or else To_File_Name (Sub_Loc.Span.Ptr) /= To_File_Name (Diag_Loc.Span.Ptr); end Should_Write_File_Name; ------------------------ -- Should_Write_Spans -- ------------------------ function Should_Write_Spans (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean is Sub_Loc : constant Labeled_Span_Id := Primary_Location (Sub_Diag); Diag_Loc : constant Labeled_Span_Id := Primary_Location (Diag); begin return Sub_Loc /= No_Labeled_Span and then Diag_Loc /= No_Labeled_Span and then Locations.Table (Sub_Loc).Span.Ptr /= Locations.Table (Diag_Loc).Span.Ptr; end Should_Write_Spans; ---------------- -- Print_Edit -- ---------------- procedure Print_Edit (Edit : Edit_Type; Offset : Integer) is Buf : constant Source_Buffer_Ptr := Source_Text (Get_Source_File_Index (Edit.Span.Ptr)); Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (Edit.Span.Ptr)); Line_Fst : constant Source_Ptr := Get_Line_Start (Buf, Edit.Span.First); Line_Lst : constant Source_Ptr := Get_Line_End (Buf, Edit.Span.First); begin Write_Str (String'(1 .. Offset => ' ')); Write_Str ("--> " & To_File_Name (Edit.Span.Ptr)); Write_Eol; -- write the original line Write_Char ('-'); Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1); Write_Buffer (Buf => Buf, First => Line_Fst, Last => Line_Lst); -- write the edited line Write_Char ('+'); Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1); Write_Buffer (Buf => Buf, First => Line_Fst, Last => Edit.Span.First - 1); if Edit.Text /= null then Write_Str (Edit.Text.all); end if; Write_Buffer (Buf => Buf, First => Edit.Span.Last + 1, Last => Line_Lst); end Print_Edit; --------------- -- Print_Fix -- --------------- procedure Print_Fix (Fix : Fix_Type; Offset : Integer) is E : Edit_Id; begin Write_Str (String'(1 .. Offset => ' ')); Write_Str ("+ Fix: "); if Fix.Description /= null then Write_Str (Fix.Description.all); end if; Write_Eol; E := Fix.Edits; while E /= No_Edit loop Print_Edit (Edits.Table (E), MAX_BAR_POS - 1); E := Edits.Table (E).Next; end loop; end Print_Fix; -------------------------- -- Print_Sub_Diagnostic -- -------------------------- procedure Print_Sub_Diagnostic (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object; Offset : Integer) is begin Write_Str (String'(1 .. Offset => ' ')); Write_Str ("+ "); Write_Str (Sub_Diag.Text.all); Write_Eol; if Should_Write_Spans (Sub_Diag, Diag) then Write_Labeled_Spans (Locations => Sub_Diag.Locations, Write_File_Name => Should_Write_File_Name (Sub_Diag, Diag), File_Name_Offset => Offset, Include_Spans => not GNATprove_Mode or else Sub_Diag.Kind /= Info, SGR_Code => SGR_Note); end if; end Print_Sub_Diagnostic; ---------------------- -- Print_Diagnostic -- ---------------------- procedure Print_Diagnostic (E : Error_Msg_Id) is E_Msg : constant Error_Msg_Object := Errors.Table (E); E_Next_Id : Error_Msg_Id; F : Fix_Id; begin -- Print the main diagnostic Write_Error_Msg_Line (E_Msg); -- Print diagnostic locations along with spans Write_Labeled_Spans (Locations => E_Msg.Locations, Write_File_Name => True, File_Name_Offset => 0, Include_Spans => not GNATprove_Mode or else E_Msg.Kind /= Info, SGR_Code => Get_SGR_Code (E_Msg)); -- Print subdiagnostics E_Next_Id := E_Msg.Next; while E_Next_Id /= No_Error_Msg and then Errors.Table (E_Next_Id).Msg_Cont loop -- Print the subdiagnostic and offset the location of the file -- name Print_Sub_Diagnostic (Errors.Table (E_Next_Id), E_Msg, MAX_BAR_POS - 1); E_Next_Id := Errors.Table (E_Next_Id).Next; end loop; -- Print fixes F := E_Msg.Fixes; while F /= No_Fix loop Print_Fix (Fixes.Table (F), MAX_BAR_POS - 1); F := Fixes.Table (F).Next; end loop; -- Separate main diagnostics with a blank line Write_Eol; end Print_Diagnostic; -------------------------- -- Print_Error_Messages -- -------------------------- procedure Print_Error_Messages is E : Error_Msg_Id; begin Set_Standard_Error; E := First_Error_Msg; while E /= No_Error_Msg loop if not Errors.Table (E).Deleted and then not Errors.Table (E).Msg_Cont then Print_Diagnostic (E); end if; E := Errors.Table (E).Next; end loop; Set_Standard_Output; end Print_Error_Messages; ------------------ -- To_File_Name -- ------------------ function To_File_Name (Sptr : Source_Ptr) return String is Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr); Ref_Name : constant File_Name_Type := (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile) else Reference_Name (Sfile)); begin return Get_Name_String (Ref_Name); end To_File_Name; -------------------- -- Line_To_String -- -------------------- function Line_To_String (Sptr : Source_Ptr) return String is Line : constant Logical_Line_Number := Get_Logical_Line_Number (Sptr); Img_Raw : constant String := Int'Image (Int (Line)); begin return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); end Line_To_String; ---------------------- -- Column_To_String -- ---------------------- function Column_To_String (Sptr : Source_Ptr) return String is Col : constant Column_Number := Get_Column_Number (Sptr); Img_Raw : constant String := Int'Image (Int (Col)); begin return (if Col < 10 then "0" else "") & Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); end Column_To_String; --------------- -- To_String -- --------------- function To_String (Sptr : Source_Ptr) return String is begin return To_File_Name (Sptr) & ":" & Line_To_String (Sptr) & ":" & Column_To_String (Sptr); end To_String; end Erroutc.Pretty_Emitter;