diff options
Diffstat (limited to 'gcc/ada/diagnostics-utils.adb')
| -rw-r--r-- | gcc/ada/diagnostics-utils.adb | 358 |
1 files changed, 358 insertions, 0 deletions
diff --git a/gcc/ada/diagnostics-utils.adb b/gcc/ada/diagnostics-utils.adb new file mode 100644 index 0000000..3203e63 --- /dev/null +++ b/gcc/ada/diagnostics-utils.adb @@ -0,0 +1,358 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . U T I L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2024, 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 Diagnostics.Repository; use Diagnostics.Repository; +with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; +with Errout; use Errout; +with Erroutc; use Erroutc; +with Namet; use Namet; +with Opt; use Opt; +with Sinput; use Sinput; +with Sinfo.Nodes; use Sinfo.Nodes; +with Warnsw; use Warnsw; + +package body Diagnostics.Utils is + + ------------------ + -- Get_Human_Id -- + ------------------ + + function Get_Human_Id (D : Diagnostic_Type) return String_Ptr is + begin + if D.Switch = No_Switch_Id then + return Diagnostic_Entries (D.Id).Human_Id; + else + return Get_Switch (D).Human_Id; + end if; + end Get_Human_Id; + + ------------------ + -- 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; + + -------------------- + -- Sloc_To_String -- + -------------------- + + function Sloc_To_String + (N : Node_Or_Entity_Id; Ref : Source_Ptr) return String + is + + begin + return Sloc_To_String (Sloc (N), Ref); + end Sloc_To_String; + + -------------------- + -- Sloc_To_String -- + -------------------- + + function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String + is + + begin + if Sptr = No_Location then + return "at unknown location"; + + elsif Sptr = System_Location then + return "in package System"; + + elsif Sptr = Standard_Location then + return "in package Standard"; + + elsif Sptr = Standard_ASCII_Location then + return "in package Standard.ASCII"; + + else + if Full_File_Name (Get_Source_File_Index (Sptr)) + /= Full_File_Name (Get_Source_File_Index (Ref)) + then + return "at " & To_String (Sptr); + else + return "at line " & Line_To_String (Sptr); + end if; + end if; + end Sloc_To_String; + + ------------------ + -- To_Full_Span -- + ------------------ + + function To_Full_Span (N : Node_Id) return Source_Span + is + Fst, Lst : Node_Id; + begin + First_And_Last_Nodes (N, Fst, Lst); + return To_Span (Ptr => Sloc (N), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst)); + end To_Full_Span; + + --------------- + -- To_String -- + --------------- + + function To_String (Id : Diagnostic_Id) return String is + begin + if Id = No_Diagnostic_Id then + return "GNAT0000"; + else + return Id'Img; + end if; + end To_String; + + ------------- + -- To_Name -- + ------------- + + function To_Name (E : Entity_Id) return String is + begin + -- The name of the node operator "&" has many special cases. Reuse the + -- node to name conversion implementation from the errout package for + -- now. + + Error_Msg_Node_1 := E; + Set_Msg_Text ("&", Sloc (E)); + + return Msg_Buffer (1 .. Msglen); + end To_Name; + + ------------------ + -- To_Type_Name -- + ------------------ + + function To_Type_Name (E : Entity_Id) return String is + begin + Error_Msg_Node_1 := E; + Set_Msg_Text ("}", Sloc (E)); + + return Msg_Buffer (1 .. Msglen); + end To_Type_Name; + + -------------------- + -- Kind_To_String -- + -------------------- + + function Kind_To_String + (D : Sub_Diagnostic_Type; + Parent : Diagnostic_Type) return String + is + (case D.Kind is + when Continuation => Kind_To_String (Parent), + when Help => "help", + when Note => "note", + when Suggestion => "suggestion"); + + -------------------- + -- Kind_To_String -- + -------------------- + + function Kind_To_String (D : Diagnostic_Type) return String is + (if D.Warn_Err then "error" + else + (case D.Kind is + when Diagnostics.Error => "error", + when Warning | Restriction_Warning | Default_Warning | + Tagless_Warning => "warning", + when Style => "style", + when Info | Info_Warning => "info")); + + ------------------------------ + -- Get_Primary_Labeled_Span -- + ------------------------------ + + function Get_Primary_Labeled_Span (Spans : Labeled_Span_List) + return Labeled_Span_Type + is + use Labeled_Span_Lists; + + S : Labeled_Span_Type; + It : Iterator; + begin + if Present (Spans) then + It := Iterate (Spans); + while Has_Next (It) loop + Next (It, S); + if S.Is_Primary then + return S; + end if; + end loop; + end if; + + return No_Labeled_Span; + end Get_Primary_Labeled_Span; + + -------------------- + -- Get_Doc_Switch -- + -------------------- + + function Get_Doc_Switch (Diag : Diagnostic_Type) return String is + begin + if Warning_Doc_Switch + and then Diag.Kind in Default_Warning + | Info + | Info_Warning + | Restriction_Warning + | Style + | Warning + then + if Diag.Switch = No_Switch_Id then + if Diag.Kind = Restriction_Warning then + return "[restriction warning]"; + + -- Info messages can have a switch tag but they should not have + -- a default switch tag. + + elsif Diag.Kind /= Info then + + -- For Default_Warning and Info_Warning + + return "[enabled by default]"; + end if; + else + declare + S : constant Switch_Type := Get_Switch (Diag); + begin + return "[-" & S.Short_Name.all & "]"; + end; + end if; + end if; + + return ""; + end Get_Doc_Switch; + + -------------------- + -- Appears_Before -- + -------------------- + + function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean is + + begin + return Appears_Before (Primary_Location (D1).Span.Ptr, + Primary_Location (D2).Span.Ptr); + end Appears_Before; + + -------------------- + -- Appears_Before -- + -------------------- + + function Appears_Before (P1, P2 : Source_Ptr) return Boolean is + + begin + if Get_Source_File_Index (P1) = Get_Source_File_Index (P2) then + if Get_Logical_Line_Number (P1) = Get_Logical_Line_Number (P2) then + return Get_Column_Number (P1) < Get_Column_Number (P2); + else + return Get_Logical_Line_Number (P1) < Get_Logical_Line_Number (P2); + end if; + else + return Get_Source_File_Index (P1) < Get_Source_File_Index (P2); + end if; + end Appears_Before; + + ------------------------------ + -- Insert_Based_On_Location -- + ------------------------------ + + procedure Insert_Based_On_Location + (List : Diagnostic_List; + Diagnostic : Diagnostic_Type) + is + use Diagnostics_Lists; + + It : Iterator := Iterate (List); + D : Diagnostic_Type; + begin + -- This is the common scenario where the error is reported at the + -- natural order the tree is processed. This saves a lot of time when + -- looking for the correct position in the list when there are a lot of + -- diagnostics. + + if Present (List) and then + not Is_Empty (List) and then + Appears_Before (Last (List), Diagnostic) + then + Append (List, Diagnostic); + else + while Has_Next (It) loop + Next (It, D); + + if Appears_Before (Diagnostic, D) then + Insert_Before (List, D, Diagnostic); + return; + end if; + end loop; + + Append (List, Diagnostic); + end if; + end Insert_Based_On_Location; + +end Diagnostics.Utils; |