diff options
Diffstat (limited to 'gcc/ada/diagnostics-utils.adb')
| -rw-r--r-- | gcc/ada/diagnostics-utils.adb | 357 |
1 files changed, 0 insertions, 357 deletions
diff --git a/gcc/ada/diagnostics-utils.adb b/gcc/ada/diagnostics-utils.adb deleted file mode 100644 index abde955..0000000 --- a/gcc/ada/diagnostics-utils.adb +++ /dev/null @@ -1,357 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-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 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 | Non_Serious_Error => "error", - when Warning | Restriction_Warning | Default_Warning | - Tagless_Warning => "warning", - when Style => "style", - when Info => "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 - | 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 - - 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; |