diff options
| author | Viljar Indus <indus@adacore.com> | 2024-06-18 15:34:32 +0300 |
|---|---|---|
| committer | Marc Poulhiès <dkm@gcc.gnu.org> | 2024-09-05 10:10:12 +0200 |
| commit | d143b9fa817759ddc041365d988dacdadafddc22 (patch) | |
| tree | f73ab20daa183437f68d74f9c23aefcc035036cc /gcc/ada | |
| parent | 47a30d6981db282a4a0e74cf02ff60a3eb0c14cf (diff) | |
| download | gcc-d143b9fa817759ddc041365d988dacdadafddc22.zip gcc-d143b9fa817759ddc041365d988dacdadafddc22.tar.gz gcc-d143b9fa817759ddc041365d988dacdadafddc22.tar.bz2 | |
ada: Integrate new diagnostics in the frontend
Integrate diagnostic messages using the new implementation to the codebase.
New diagnostic implementation uses GNAT.Lists as a building
block. Tampering checks that were initially implemented
for those lists are not critical for this implementation and
they lead to overly complex code.
Add a generic parameter Tampering_Checks to control whether
the tempering checks should be applied for the lists.
Make tampering checks conditional for GNAT.Lists
gcc/ada/
* par-endh.adb: add call to new diagnostic for end loop errors.
* sem_ch13.adb: add call to new diagnostic for default iterator
error and record representation being too late.
* sem_ch4.adb: Add new diagnostic for wrong operands.
* sem_ch9.adb: Add new diagnostic for a Lock_Free warning.
* libgnat/g-lists.adb (Ensure_Unlocked): Make checks for tampering
conditional.
* libgnat/g-lists.ads: Add parameter Tampering_Checks to control
whether tampering checks should be executed.
* backend_utils.adb: Add new gcc switches
'-fdiagnostics-format=sarif-file' and
'-fdiagnostics-format=sarif-stderr'.
* debug.adb: document -gnatd_D switch.
* diagnostics-brief_emitter.adb: New package for displaying
diagnostic messages in a compact manner.
* diagnostics-brief_emitter.ads: Same as above.
* diagnostics-constructors.adb: New pacakge for providing simpler
constructor methods for new diagnostic objects.
* diagnostics-constructors.ads: Same as above.
* diagnostics-converter.adb: New package for converting old
Error_Msg_Object-s to Diagnostic_Types.
* diagnostics-converter.ads: Same as above.
* diagnostics-json_utils.adb: Package for utility methods related
to emitting JSON.
* diagnostics-json_utils.ads: Same as above.
* diagnostics-pretty_emitter.adb: New package for displaying
diagnostic messages in a more elaborate manner.
* diagnostics-pretty_emitter.ads: Same as above.
* diagnostics-repository.adb: New package for collecting all
created error messages.
* diagnostics-repository.ads: Same as above.
* diagnostics-sarif_emitter.adb: New pacakge for converting all of
the diagnostics into a report in the SARIF format.
* diagnostics-sarif_emitter.ads: Same as above.
* diagnostics-switch_repository.adb: New package containing the
definitions for all of the warninging switches.
* diagnostics-switch_repository.ads: Same as above.
* diagnostics-utils.adb: Contains various utility methods for the
diagnostic pacakges.
* diagnostics-utils.ads: Same as above.
* diagnostics.adb: Contains the definitions and common functions
for all the new diagnostics objects.
* diagnostics.ads: Same as above.
* errout.adb: Relocate the old implementations for brief and
pretty printing the diagnostic messages and the entrypoint to the
new implementation if a debug switch is used.
* errout.ads: Improve documentation. Make Set_Msg_Text publicly
available.
* opt.ads: Add the flag SARIF_File which controls whether the
diagnostic messages should be printed to a file in the SARIF
format. Add the flag SARIF_Output to control whether the
diagnostic messages should be printed to std-err in the SARIF
format.
* gcc-interface/Make-lang.in: Add new pacakages to the object
list.
* gcc-interface/Makefile.in: Add new pacakages to the object list.
Diffstat (limited to 'gcc/ada')
33 files changed, 6460 insertions, 158 deletions
diff --git a/gcc/ada/backend_utils.adb b/gcc/ada/backend_utils.adb index 3591cd1..f734a06 100644 --- a/gcc/ada/backend_utils.adb +++ b/gcc/ada/backend_utils.adb @@ -65,6 +65,21 @@ package body Backend_Utils is elsif Switch_Chars (First .. Last) = "fdiagnostics-format=json" then Opt.JSON_Output := True; + -- Back end switch -fdiagnostics-format=sarif-file tells the frontend + -- to output its error and warning messages in the sarif format. The + -- messages from gnat are written to a file <source_file>.gnat.sarif. + + elsif Switch_Chars (First .. Last) = "fdiagnostics-format=sarif-file" + then + Opt.SARIF_File := True; + + -- Back end switch -fdiagnostics-format=sarif-stderr tells the frontend + -- to output its error and warning messages in the sarif format. + + elsif Switch_Chars (First .. Last) = "fdiagnostics-format=sarif-stderr" + then + Opt.SARIF_Output := True; + -- Back-end switch -fno-inline also sets the front end flags to entirely -- inhibit all inlining. So we store it and set the appropriate -- flags. diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index fcd04df..2c0bff0 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -168,8 +168,8 @@ package body Debug is -- d_A Stop generation of ALI file -- d_B Warn on build-in-place function calls -- d_C - -- d_D - -- d_E + -- d_D Use improved diagnostics + -- d_E Print diagnostics and switch repository -- d_F Encode full invocation paths in ALI files -- d_G -- d_H diff --git a/gcc/ada/diagnostics-brief_emitter.adb b/gcc/ada/diagnostics-brief_emitter.adb new file mode 100644 index 0000000..9ba137e --- /dev/null +++ b/gcc/ada/diagnostics-brief_emitter.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . B R I E F _ E M I T T E R -- +-- -- +-- 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.Utils; use Diagnostics.Utils; +with Erroutc; use Erroutc; +with Opt; use Opt; +with Output; use Output; + +package body Diagnostics.Brief_Emitter is + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type); + + -------------------------- + -- Print_Sub_Diagnostic -- + -------------------------- + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + is + -- In GNAT sub messages were grouped by the main messages by also having + -- the same location. In the brief printer we use the primary location + -- of the main diagnostic for all of the subdiagnostics. + Prim_Loc : constant Labeled_Span_Type := Primary_Location (Diag); + + Sptr : constant Source_Ptr := Prim_Loc.Span.Ptr; + + Text : String_Ptr; + + Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last + else Error_Msg_Line_Length); + + Switch_Str : constant String := Get_Doc_Switch (Diag); + begin + Text := new String'(To_String (Sptr) & ": " + & Kind_To_String (Sub_Diag, Diag) & ": " + & Sub_Diag.Message.all); + + if Switch_Str /= "" then + Text := new String'(Text.all & " " & Switch_Str); + end if; + + if Diag.Warn_Err then + Text := new String'(Text.all & " [warning-as-error]"); + end if; + + Output_Text_Within (Text, Line_Length); + Write_Eol; + end Print_Sub_Diagnostic; + + ---------------------- + -- Print_Diagnostic -- + ---------------------- + + procedure Print_Diagnostic (Diag : Diagnostic_Type) is + use Sub_Diagnostic_Lists; + + Prim_Loc : constant Labeled_Span_Type := Primary_Location (Diag); + + Sptr : constant Source_Ptr := Prim_Loc.Span.Ptr; + + Text : String_Ptr; + + Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last + else Error_Msg_Line_Length); + + Switch_Str : constant String := Get_Doc_Switch (Diag); + begin + Write_Str (To_String (Sptr) & ": "); + + -- Ignore the message prefix on Style messages. They will use + -- the (style) prefix within the message. + -- + -- Also disable the "error:" prefix if Unique_Error_Tag is unset. + + if (Diag.Kind = Style and then not Diag.Warn_Err) + or else (Diag.Kind = Error and then not Unique_Error_Tag) + then + Text := new String'(""); + else + Text := new String'(Kind_To_String (Diag) & ": "); + end if; + + Text := new String'(Text.all & Diag.Message.all); + + if Switch_Str /= "" then + Text := new String'(Text.all & " " & Switch_Str); + end if; + + if Diag.Warn_Err then + Text := new String'(Text.all & " [warning-as-error]"); + end if; + + Output_Text_Within (Text, Line_Length); + Write_Eol; + + if Present (Diag.Sub_Diagnostics) then + declare + + Sub_Diag : Sub_Diagnostic_Type; + + It : Iterator := Iterate (Diag.Sub_Diagnostics); + begin + while Has_Next (It) loop + Next (It, Sub_Diag); + + Print_Sub_Diagnostic (Sub_Diag, Diag); + end loop; + end; + end if; + + end Print_Diagnostic; +end Diagnostics.Brief_Emitter; diff --git a/gcc/ada/diagnostics-brief_emitter.ads b/gcc/ada/diagnostics-brief_emitter.ads new file mode 100644 index 0000000..1759b21 --- /dev/null +++ b/gcc/ada/diagnostics-brief_emitter.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . B R I E F _ E M I T T E R -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Brief_Emitter is + procedure Print_Diagnostic (Diag : Diagnostic_Type); +end Diagnostics.Brief_Emitter; diff --git a/gcc/ada/diagnostics-constructors.adb b/gcc/ada/diagnostics-constructors.adb new file mode 100644 index 0000000..8a9e10a --- /dev/null +++ b/gcc/ada/diagnostics-constructors.adb @@ -0,0 +1,475 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N S T R U C T O R 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 Sinfo.Nodes; use Sinfo.Nodes; +with Diagnostics.Utils; use Diagnostics.Utils; + +package body Diagnostics.Constructors is + + ----------------------------------------------- + -- Make_Default_Iterator_Not_Primitive_Error -- + ----------------------------------------------- + + function Make_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "improper function for default iterator", + Location => Primary_Labeled_Span (Expr), + Id => GNAT0001, + Kind => Diagnostics.Error, + Sub_Diags => + (1 => + Continuation + (Msg => + "default iterator defined " & + Sloc_To_String (Subp, Sloc (Expr)) & + " must be a primitive function", + Locations => + (1 => Primary_Labeled_Span (Subp))))); + end Make_Default_Iterator_Not_Primitive_Error; + + ------------------------------------------------- + -- Record_Default_Iterator_Not_Primitive_Error -- + ------------------------------------------------- + + procedure Record_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id) + is + begin + Record_Diagnostic + (Make_Default_Iterator_Not_Primitive_Error (Expr, Subp)); + end Record_Default_Iterator_Not_Primitive_Error; + + --------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_Error -- + --------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0002, + Kind => Diagnostics.Error, + Spans => + (1 => + (Secondary_Labeled_Span + (N => L, + Label => To_Type_Name (L_Type))), + 2 => + Secondary_Labeled_Span + (N => R, + Label => To_Type_Name (R_Type)))); + end Make_Invalid_Operand_Types_For_Operator_Error; + + ----------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_Error -- + ----------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) + is + + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_Error + (Op, L, L_Type, R, R_Type)); + end Record_Invalid_Operand_Types_For_Operator_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_L_Int_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0003, + Kind => Diagnostics.Error, + Spans => + (1 => + (Secondary_Labeled_Span + (N => L, + Label => + "left operand has type " & + To_Name (L_Type))), + 2 => + Secondary_Labeled_Span + (N => R, + Label => + "right operand has type " & + To_Name (R_Type))), + Sub_Diags => + (1 => Suggestion (Msg => "Convert left operand to ""Integer""") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_L_Int_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_L_Int_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) + is + + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op, L, L_Type, R, R_Type)); + end Record_Invalid_Operand_Types_For_Operator_L_Int_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_R_Int_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0004, + Kind => Diagnostics.Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => L, + Label => + "left operand has type " & + To_Name (L_Type)), + 2 => + Secondary_Labeled_Span + (N => R, + Label => + "right operand has type " & + To_Name (R_Type))), + Sub_Diags => + (1 => Suggestion (Msg => "Convert right operand to ""Integer""") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_R_Int_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_R_Int_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) + is + + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op, L, L_Type, R, R_Type)); + end Record_Invalid_Operand_Types_For_Operator_R_Int_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_L_Acc_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id) return Diagnostic_Type + is + + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0005, + Kind => Diagnostics.Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => L, + Label => + "left operand is access type ") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_L_Acc_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_L_Acc_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id) + is + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op, L)); + end Record_Invalid_Operand_Types_For_Operator_L_Acc_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_L_Acc_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id) return Diagnostic_Type + is + + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0006, + Kind => Diagnostics.Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => R, + Label => + "right operand is access type ") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_R_Acc_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_R_Acc_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id) + is + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op, R)); + end Record_Invalid_Operand_Types_For_Operator_R_Acc_Error; + + ----------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_General_Error -- + ----------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id) return Diagnostic_Type + is + + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0007, + Kind => Diagnostics.Error + ); + end Make_Invalid_Operand_Types_For_Operator_General_Error; + + ------------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_General_Error -- + ------------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id) + is + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_General_Error (Op)); + end Record_Invalid_Operand_Types_For_Operator_General_Error; + + -------------------------------------------------- + -- Make_Pragma_No_Effect_With_Lock_Free_Warning -- + -------------------------------------------------- + + function Make_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; Lock_Free_Range : Node_Id) + return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => + "pragma " & '"' & Get_Name_String (Pragma_Name) & '"' & + " for " & To_Name (Lock_Free_Node) & + " has no effect when Lock_Free given", + Location => Primary_Labeled_Span (Pragma_Node, "No effect"), + Id => GNAT0008, + Kind => Diagnostics.Warning, + Spans => + (1 => + Labeled_Span + (Span => To_Full_Span (Lock_Free_Range), + Label => "Lock_Free in effect here", + Is_Primary => False, + Is_Region => True))); + end Make_Pragma_No_Effect_With_Lock_Free_Warning; + + -------------------------------------------- + -- Record_Pragma_No_Effect_With_Lock_Free -- + -------------------------------------------- + + procedure Record_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; + Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; + Lock_Free_Range : Node_Id) + is + begin + Record_Diagnostic + (Make_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node, Pragma_Name, Lock_Free_Node, Lock_Free_Range)); + end Record_Pragma_No_Effect_With_Lock_Free_Warning; + + ---------------------------------- + -- Make_End_Loop_Expected_Error -- + ---------------------------------- + + function Make_End_Loop_Expected_Error + (End_Loc : Source_Span; + Start_Loc : Source_Ptr) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => + """end loop;"" expected for ""loop"" " & + Sloc_To_String (Start_Loc, End_Loc.Ptr), + Location => Primary_Labeled_Span (End_Loc), + Id => GNAT0009, + Kind => Diagnostics.Error, + Spans => (1 => Secondary_Labeled_Span (To_Span (Start_Loc))), + Fixes => + (1 => + Fix + (Description => "Replace with 'end loop;'", + Edits => + (1 => Edit (Text => "end loop;", Span => End_Loc)), + Applicability => Legal))); + end Make_End_Loop_Expected_Error; + + ------------------------------------ + -- Record_End_Loop_Expected_Error -- + ------------------------------------ + + procedure Record_End_Loop_Expected_Error + (End_Loc : Source_Span; Start_Loc : Source_Ptr) + is + begin + Record_Diagnostic (Make_End_Loop_Expected_Error (End_Loc, Start_Loc)); + end Record_End_Loop_Expected_Error; + + ---------------------------------------- + -- Make_Representation_Too_Late_Error -- + ---------------------------------------- + + function Make_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id) + return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => + "record representation cannot be specified" & + " after the type is frozen", + Location => + Primary_Labeled_Span + (N => Rep, + Label => "record representation clause specified here"), + Id => GNAT0010, + Kind => Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => Freeze, + Label => + "Type " & To_Name (Def) & " is frozen here"), + 2 => + Secondary_Labeled_Span + (N => Def, + Label => + "Type " & To_Name (Def) & " is declared here")), + Sub_Diags => + (1 => + Suggestion + (Msg => + "move the record representation clause" & + " before the freeze point " & + Sloc_To_String (Sloc (Freeze), Sloc (Rep))))); + end Make_Representation_Too_Late_Error; + + ------------------------------------------ + -- Record_Representation_Too_Late_Error -- + ------------------------------------------ + + procedure Record_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id) + is + begin + Record_Diagnostic + (Make_Representation_Too_Late_Error (Rep, Freeze, Def)); + end Record_Representation_Too_Late_Error; + +end Diagnostics.Constructors; diff --git a/gcc/ada/diagnostics-constructors.ads b/gcc/ada/diagnostics-constructors.ads new file mode 100644 index 0000000..96782b3 --- /dev/null +++ b/gcc/ada/diagnostics-constructors.ads @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N S T R U C T O R S -- +-- -- +-- S p e c -- +-- -- +-- 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 Namet; use Namet; + +package Diagnostics.Constructors is + + function Make_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id) return Diagnostic_Type; + + procedure Record_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id); + + function Make_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id); + + function Make_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; + Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; + Lock_Free_Range : Node_Id) + return Diagnostic_Type; + + procedure Record_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; + Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; + Lock_Free_Range : Node_Id); + + function Make_End_Loop_Expected_Error + (End_Loc : Source_Span; + Start_Loc : Source_Ptr) return Diagnostic_Type; + + procedure Record_End_Loop_Expected_Error + (End_Loc : Source_Span; + Start_Loc : Source_Ptr); + + function Make_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id) + return Diagnostic_Type; + + procedure Record_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id); + +end Diagnostics.Constructors; diff --git a/gcc/ada/diagnostics-converter.adb b/gcc/ada/diagnostics-converter.adb new file mode 100644 index 0000000..45bb19c --- /dev/null +++ b/gcc/ada/diagnostics-converter.adb @@ -0,0 +1,281 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N V E R T E R -- +-- -- +-- 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 Erroutc; use Erroutc; +with Debug; use Debug; +with Diagnostics.Repository; use Diagnostics.Repository; +with Diagnostics.SARIF_Emitter; use Diagnostics.SARIF_Emitter; +with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +use Diagnostics.Diagnostics_Lists; +with System.OS_Lib; use System.OS_Lib; + +package body Diagnostics.Converter is + + function Convert (E_Id : Error_Msg_Id) return Diagnostic_Type; + + function Convert_Sub_Diagnostic + (E_Id : Error_Msg_Id) return Sub_Diagnostic_Type; + + function Get_Warning_Kind (E_Msg : Error_Msg_Object) return Diagnostic_Kind + is (if E_Msg.Info then Info_Warning + elsif E_Msg.Warn_Chr = "* " then Restriction_Warning + elsif E_Msg.Warn_Chr = "? " then Default_Warning + elsif E_Msg.Warn_Chr = " " then Tagless_Warning + else Warning); + -- NOTE: Some messages have both info and warning set to true. The old + -- printer added the warning switch label but treated the message as + -- an info message. + + ----------------------------------- + -- Convert_Errors_To_Diagnostics -- + ----------------------------------- + + procedure Convert_Errors_To_Diagnostics + is + E : Error_Msg_Id; + begin + 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 + + -- We do not need to update the count of converted error messages + -- since they are accounted for in their creation. + + Record_Diagnostic (Convert (E), Update_Count => False); + end if; + + E := Errors.Table (E).Next; + end loop; + + end Convert_Errors_To_Diagnostics; + + ---------------------------- + -- Convert_Sub_Diagnostic -- + ---------------------------- + + function Convert_Sub_Diagnostic + (E_Id : Error_Msg_Id) return Sub_Diagnostic_Type + is + E_Msg : constant Error_Msg_Object := Errors.Table (E_Id); + D : Sub_Diagnostic_Type; + begin + D.Message := E_Msg.Text; + + -- All converted sub-diagnostics are continuations. When emitted they + -- shall be printed with the same kind token as the main diagnostic. + D.Kind := Continuation; + + declare + L : Labeled_Span_Type; + begin + if E_Msg.Insertion_Sloc /= No_Location then + L.Span := To_Span (E_Msg.Insertion_Sloc); + else + L.Span := E_Msg.Sptr; + end if; + + L.Is_Primary := True; + Add_Location (D, L); + end; + + if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then + declare + L : Labeled_Span_Type; + begin + L.Span := E_Msg.Optr; + L.Is_Primary := False; + Add_Location (D, L); + end; + end if; + + return D; + end Convert_Sub_Diagnostic; + + ------------- + -- Convert -- + ------------- + + function Convert (E_Id : Error_Msg_Id) return Diagnostic_Type is + + E_Next_Id : Error_Msg_Id; + + E_Msg : constant Error_Msg_Object := Errors.Table (E_Id); + D : Diagnostic_Type; + begin + D.Message := E_Msg.Text; + + if E_Msg.Warn then + D.Kind := Get_Warning_Kind (E_Msg); + D.Switch := Get_Switch_Id (E_Msg); + elsif E_Msg.Style then + D.Kind := Style; + D.Switch := Get_Switch_Id (E_Msg); + elsif E_Msg.Info then + D.Kind := Info; + D.Switch := Get_Switch_Id (E_Msg); + else + D.Kind := Error; + end if; + + D.Warn_Err := E_Msg.Warn_Err; + + D.Serious := E_Msg.Serious; + + -- Convert the primary location + + declare + L : Labeled_Span_Type; + begin + L.Span := E_Msg.Sptr; + L.Is_Primary := True; + Add_Location (D, L); + end; + + -- Convert the secondary location if it is different from the primary + + if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then + declare + L : Labeled_Span_Type; + begin + L.Span := E_Msg.Optr; + L.Is_Primary := False; + Add_Location (D, L); + end; + end if; + + E_Next_Id := Errors.Table (E_Id).Next; + while E_Next_Id /= No_Error_Msg + and then Errors.Table (E_Next_Id).Msg_Cont + loop + Add_Sub_Diagnostic (D, Convert_Sub_Diagnostic (E_Next_Id)); + E_Next_Id := Errors.Table (E_Next_Id).Next; + end loop; + + return D; + end Convert; + + ---------------------- + -- Emit_Diagnostics -- + ---------------------- + + procedure Emit_Diagnostics is + D : Diagnostic_Type; + + It : Iterator := Iterate (All_Diagnostics); + + Sarif_File_Name : constant String := + Get_First_Main_File_Name & ".gnat.sarif"; + + Switches_File_Name : constant String := "gnat_switches.json"; + + Diagnostics_File_Name : constant String := "gnat_diagnostics.json"; + + Dummy : Boolean; + begin + if Opt.SARIF_Output then + Set_Standard_Error; + + Print_SARIF_Report (All_Diagnostics); + + Set_Standard_Output; + elsif Opt.SARIF_File then + Delete_File (Sarif_File_Name, Dummy); + declare + Output_FD : constant File_Descriptor := + Create_New_File + (Sarif_File_Name, + Fmode => Text); + + begin + Set_Output (Output_FD); + + Print_SARIF_Report (All_Diagnostics); + + Set_Standard_Output; + + Close (Output_FD); + end; + else + Set_Standard_Error; + + while Has_Next (It) loop + Next (It, D); + + Print_Diagnostic (D); + end loop; + + Set_Standard_Output; + end if; + + if Debug_Flag_Underscore_EE then + + -- Print the switch repository to a file + + Delete_File (Switches_File_Name, Dummy); + declare + Output_FD : constant File_Descriptor := + Create_New_File + (Switches_File_Name, + Fmode => Text); + + begin + Set_Output (Output_FD); + + Print_Switch_Repository; + + Set_Standard_Output; + + Close (Output_FD); + end; + + -- Print the diagnostics repository to a file + + Delete_File (Diagnostics_File_Name, Dummy); + declare + Output_FD : constant File_Descriptor := + Create_New_File + (Diagnostics_File_Name, + Fmode => Text); + + begin + Set_Output (Output_FD); + + Print_Diagnostic_Repository; + + Set_Standard_Output; + + Close (Output_FD); + end; + end if; + + Destroy (All_Diagnostics); + end Emit_Diagnostics; + +end Diagnostics.Converter; diff --git a/gcc/ada/diagnostics-converter.ads b/gcc/ada/diagnostics-converter.ads new file mode 100644 index 0000000..8436ed1 --- /dev/null +++ b/gcc/ada/diagnostics-converter.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N V E R T E R -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Converter is + + procedure Convert_Errors_To_Diagnostics; + + procedure Emit_Diagnostics; +end Diagnostics.Converter; diff --git a/gcc/ada/diagnostics-json_utils.adb b/gcc/ada/diagnostics-json_utils.adb new file mode 100644 index 0000000..30263b0 --- /dev/null +++ b/gcc/ada/diagnostics-json_utils.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . J S O N _ 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 Output; use Output; + +package body Diagnostics.JSON_Utils is + + ----------------- + -- Begin_Block -- + ----------------- + + procedure Begin_Block is + begin + Indent_Level := Indent_Level + 1; + end Begin_Block; + + --------------- + -- End_Block -- + --------------- + + procedure End_Block is + begin + Indent_Level := Indent_Level - 1; + end End_Block; + + procedure Indent is begin + if JSON_FORMATTING then + for I in 1 .. INDENT_SIZE * Indent_Level loop + Write_Char (' '); + end loop; + end if; + end Indent; + + ------------------- + -- NL_And_Indent -- + ------------------- + + procedure NL_And_Indent is + begin + if JSON_FORMATTING then + Write_Eol; + Indent; + end if; + end NL_And_Indent; + + ------------------------- + -- Write_Int_Attribute -- + ------------------------- + + procedure Write_Int_Attribute (Name : String; Value : Int) is + begin + Write_Str ("""" & Name & """" & ": "); + Write_Int (Value); + end Write_Int_Attribute; + + ------------------------------- + -- Write_JSON_Escaped_String -- + ------------------------------- + + procedure Write_JSON_Escaped_String (Str : String) is + begin + for C of Str loop + if C = '"' or else C = '\' then + Write_Char ('\'); + end if; + + Write_Char (C); + end loop; + end Write_JSON_Escaped_String; + + ---------------------------- + -- Write_String_Attribute -- + ---------------------------- + + procedure Write_String_Attribute (Name : String; Value : String) is + begin + Write_Str ("""" & Name & """" & ": "); + Write_Char ('"'); + Write_JSON_Escaped_String (Value); + Write_Char ('"'); + end Write_String_Attribute; + +end Diagnostics.JSON_Utils; diff --git a/gcc/ada/diagnostics-json_utils.ads b/gcc/ada/diagnostics-json_utils.ads new file mode 100644 index 0000000..1fc6c0e --- /dev/null +++ b/gcc/ada/diagnostics-json_utils.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . J S O N _ U T I L S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.JSON_Utils is + + JSON_FORMATTING : constant Boolean := True; + -- Adds newlines and indentation to the output JSON. + -- + -- NOTE: This flag could be associated with the gcc switch: + -- '-fno-diagnostics-json-formatting' + + INDENT_SIZE : constant := 2; + -- The number of spaces to indent each level of the JSON output. + + Indent_Level : Natural := 0; + -- The current indentation level. + + procedure Begin_Block; + -- Increase the indentation level by one + + procedure End_Block; + -- Decrease the indentation level by one + + procedure Indent; + -- Print the indentation for the line + + procedure NL_And_Indent; + -- Print a new line + + procedure Write_Int_Attribute (Name : String; Value : Int); + + procedure Write_JSON_Escaped_String (Str : String); + -- Write each character of Str, taking care of preceding each quote and + -- backslash with a backslash. Note that this escaping differs from what + -- GCC does. + -- + -- Indeed, the JSON specification mandates encoding wide characters + -- either as their direct UTF-8 representation or as their escaped + -- UTF-16 surrogate pairs representation. GCC seems to prefer escaping - + -- we choose to use the UTF-8 representation instead. + + procedure Write_String_Attribute (Name : String; Value : String); + -- Write a JSON attribute with a string value + +end Diagnostics.JSON_Utils; diff --git a/gcc/ada/diagnostics-pretty_emitter.adb b/gcc/ada/diagnostics-pretty_emitter.adb new file mode 100644 index 0000000..927e505 --- /dev/null +++ b/gcc/ada/diagnostics-pretty_emitter.adb @@ -0,0 +1,1277 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . P R E T T Y _ E M I T T E R -- +-- -- +-- 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.Utils; use Diagnostics.Utils; +with Output; use Output; +with Sinput; use Sinput; +with Erroutc; use Erroutc; + +package body Diagnostics.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 + 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 + + 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 (Spans : Labeled_Span_List) + 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 Has_Region_Span_Start (L : Printable_Line) return Boolean; + function Has_Region_Span_End (L : Printable_Line) return Boolean; + + function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean; + + procedure Write_Region_Delimiter; + -- Write the arms signifying the start and end of a region span + -- e.g. +-- + + procedure Write_Region_Bar; + -- Write the bar signifying the continuation of a region span + -- e.g. | + + procedure Write_Region_Continuation; + -- 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; + + procedure Write_Span_Labels (Loc : Labeled_Span_Type; + L : Printable_Line; + Line_Size : Integer; + Idx : String; + Within_Region_Span : Boolean); + + procedure Write_File_Section (Sec : File_Sections; + Write_File_Name : Boolean; + File_Name_Offset : Integer); + + procedure Write_Labeled_Spans (Spans : Labeled_Span_List; + Write_File_Name : Boolean; + File_Name_Offset : Integer); + + procedure Write_Intersecting_Labels + (Intersecting_Labels : Labeled_Span_List); + + function Get_Line_End + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr; + -- Get the source location for the end of the line 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 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); + + procedure Write_Empty_Bar_Line (Width : Integer); + + procedure Write_Empty_Skip_Line (Width : Integer); + + procedure Write_Error_Msg_Line (Diag : Diagnostic_Type); + -- Write the error message line for the given diagnostic: + -- + -- '['<Diag.Id>']' <Diag.Kind>: <Diag.Message> ['['<Diag.Switch>']'] + + function Should_Write_File_Name (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) 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 : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + 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_Edit + (Edit : Edit_Type; + Offset : Integer); + + procedure Print_Fix + (Fix : Fix_Type; + Offset : Integer); + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type; + Offset : Integer); + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Printable_Line) + is + begin + -- Diagnostic elements will be freed when all the diagnostics have been + -- emitted. + null; + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out File_Sections) + is + begin + Free (Elem.File); + 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; + + ----------- + -- 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; + + --------------------------- + -- Has_Region_Span_Start -- + --------------------------- + + function Has_Region_Span_Start (L : Printable_Line) return Boolean is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (L.Spans); + + Has_Region_Start : Boolean := False; + begin + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + if not Has_Region_Start + and then Loc.Is_Region + and then L.Line_Nr = + Pos (Get_Physical_Line_Number (Loc.Span.First)) + then + Has_Region_Start := True; + end if; + end loop; + return Has_Region_Start; + end Has_Region_Span_Start; + + ------------------------- + -- Has_Region_Span_End -- + ------------------------- + + function Has_Region_Span_End (L : Printable_Line) return Boolean is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (L.Spans); + + Has_Region_End : Boolean := False; + begin + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + if not Has_Region_End + and then Loc.Is_Region + and then L.Line_Nr = + Pos (Get_Physical_Line_Number (Loc.Span.Last)) + then + Has_Region_End := True; + end if; + end loop; + return Has_Region_End; + end Has_Region_Span_End; + + ------------------ + -- 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 is + + begin + Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str ("+"); + Write_Str (String'(1 .. REGION_ARM_SIZE => '-')); + end Write_Region_Delimiter; + + ---------------------- + -- Write_Region_Bar -- + ---------------------- + + procedure Write_Region_Bar is + + begin + Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str ("|"); + Write_Str (String'(1 .. REGION_ARM_SIZE => ' ')); + end Write_Region_Bar; + + ------------------------------- + -- Write_Region_Continuation -- + ------------------------------- + + procedure Write_Region_Continuation is + + begin + Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str (":"); + 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; + + if Found_Greater_Line then + + -- Insert after all the lines have been iterated over to avoid the + -- mutation lock in GNAT.Lists + + null; + else + 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)), + Lines => Lines)); + end Create_File_Section; + + -------------------------- + -- Create_File_Sections -- + -------------------------- + + function Create_File_Sections + (Spans : Labeled_Span_List) return File_Section_List + is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Spans); + + Sections : File_Section_List := File_Section_Lists.Create; + + Sec : File_Sections; + F_It : File_Section_Lists.Iterator; + + File_Found : Boolean; + begin + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + 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); + end if; + end loop; + + if not File_Found then + Create_File_Section (Sections, Loc); + end if; + 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) + 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 (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; + else + Write_Region_Offset; + end if; + + Write_Str (String'(1 .. Span_Fst - 1 => ' ')); + + 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_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; + else + Write_Region_Offset; + end if; + + Write_Str (String'(1 .. Span_Fst - 1 => ' ')); + Write_Str (Loc.Label.all); + 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 (Loc.Label.all); + 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) + is + Ls : Labeled_Span_Type; + Ls_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Intersecting_Labels); + Idx : Integer := 0; + begin + while Labeled_Span_Lists.Has_Next (Ls_It) loop + Labeled_Span_Lists.Next (Ls_It, Ls); + Idx := Idx + 1; + + Write_Empty_Bar_Line (MAX_BAR_POS); + Write_Str (" "); + Write_Int (Int (Idx)); + Write_Str (": "); + Write_Str (Ls.Label.all); + 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) + is + use Lines_Lists; + + L : Printable_Line; + L_It : Iterator := Iterate (Sec.Lines); + + -- The error should be included in the first (primary) span of the file. + Loc : constant Labeled_Span_Type := + Labeled_Span_Lists.First (Lines_Lists.First (Sec.Lines).Spans); + + 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 (Loc.Span.Ptr)); + Write_Eol; + 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)); + + Contains_Region_Span_Start : constant Boolean := + Has_Region_Span_Start (L); + Contains_Region_Span_End : constant Boolean := + Has_Region_Span_End (L); + 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; + 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; + elsif Within_Region_Span then + Write_Region_Bar; + 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, + L, + Line_Size, + Trimmed_Image (Idx), + Within_Region_Span); + else + Write_Span_Labels (Loc, + L, + Line_Size, + "", + Within_Region_Span); + 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); + end Write_File_Section; + + ------------------------- + -- Write_Labeled_Spans -- + ------------------------- + + procedure Write_Labeled_Spans (Spans : Labeled_Span_List; + Write_File_Name : Boolean; + File_Name_Offset : Integer) + is + Sections : File_Section_List := Create_File_Sections (Spans); + + 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, Write_File_Name, File_Name_Offset); + end loop; + + File_Section_Lists.Destroy (Sections); + end Write_Labeled_Spans; + + -------------------------- + -- Write_Error_Msg_Line -- + -------------------------- + + procedure Write_Error_Msg_Line (Diag : Diagnostic_Type) is + Switch_Str : constant String := Get_Doc_Switch (Diag); + + Kind_Str : constant String := Kind_To_String (Diag); + + SGR_Code : constant String := + (if Kind_Str = "error" then SGR_Error + elsif Kind_Str = "warning" then SGR_Warning + elsif Kind_Str = "info" then SGR_Note + else SGR_Reset); + begin + Write_Str (SGR_Code); + + Write_Str ("[" & To_String (Diag.Id) & "]"); + + Write_Str (" " & Kind_To_String (Diag) & ": "); + + Write_Str (SGR_Reset); + + Write_Str (Diag.Message.all); + + if Switch_Str /= "" then + Write_Str (" " & Switch_Str); + end if; + + if Diag.Warn_Err then + Write_Str (" [warning-as-error]"); + end if; + + Write_Eol; + end Write_Error_Msg_Line; + + ---------------------------- + -- Should_Write_File_Name -- + ---------------------------- + + function Should_Write_File_Name (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + return Boolean + is + Sub_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Sub_Diag.Locations); + + Diag_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Diag.Locations); + + function Has_Multiple_Files (Spans : Labeled_Span_List) return Boolean; + + ------------------------ + -- Has_Multiple_Files -- + ------------------------ + + function Has_Multiple_Files + (Spans : Labeled_Span_List) return Boolean + is + First : constant Labeled_Span_Type := + Labeled_Span_Lists.First (Spans); + + File : constant String := To_File_Name (First.Span.Ptr); + + Loc : Labeled_Span_Type; + It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Spans); + + begin + while Labeled_Span_Lists.Has_Next (It) loop + Labeled_Span_Lists.Next (It, Loc); + + if To_File_Name (Loc.Span.Ptr) /= File then + return True; + end if; + end loop; + return False; + end Has_Multiple_Files; + begin + return + Has_Multiple_Files (Diag.Locations) + 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 : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + return Boolean + is + Sub_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Sub_Diag.Locations); + + Diag_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Diag.Locations); + begin + return Sub_Loc /= No_Labeled_Span + and then Diag_Loc /= No_Labeled_Span + and then Sub_Loc.Span.Ptr /= 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 + use Edit_Lists; + begin + Write_Str (String'(1 .. Offset => ' ')); + Write_Str ("+ Fix: "); + + if Fix.Description /= null then + Write_Str (Fix.Description.all); + end if; + Write_Eol; + + if Present (Fix.Edits) then + declare + Edit : Edit_Type; + + It : Iterator := Iterate (Fix.Edits); + begin + while Has_Next (It) loop + Next (It, Edit); + + Print_Edit (Edit, MAX_BAR_POS - 1); + end loop; + end; + end if; + end Print_Fix; + + -------------------------- + -- Print_Sub_Diagnostic -- + -------------------------- + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type; + Offset : Integer) + is + begin + Write_Str (String'(1 .. Offset => ' ')); + + if Sub_Diag.Kind = Suggestion then + Write_Str ("+ Suggestion: "); + else + Write_Str ("+ "); + end if; + + Write_Str (Sub_Diag.Message.all); + Write_Eol; + + if Should_Write_Spans (Sub_Diag, Diag) then + Write_Labeled_Spans (Sub_Diag.Locations, + Should_Write_File_Name (Sub_Diag, Diag), + Offset); + end if; + end Print_Sub_Diagnostic; + + ---------------------- + -- Print_Diagnostic -- + ---------------------- + + procedure Print_Diagnostic (Diag : Diagnostic_Type) is + + begin + -- Print the main diagnostic + + Write_Error_Msg_Line (Diag); + + -- Print diagnostic locations along with spans + + Write_Labeled_Spans (Diag.Locations, True, 0); + + -- Print subdiagnostics + + if Sub_Diagnostic_Lists.Present (Diag.Sub_Diagnostics) then + declare + use Sub_Diagnostic_Lists; + Sub_Diag : Sub_Diagnostic_Type; + + It : Iterator := Iterate (Diag.Sub_Diagnostics); + begin + while Has_Next (It) loop + Next (It, Sub_Diag); + + -- Print the subdiagnostic and offset the location of the file + -- name + + Print_Sub_Diagnostic (Sub_Diag, Diag, MAX_BAR_POS - 1); + end loop; + end; + end if; + + -- Print fixes + + if Fix_Lists.Present (Diag.Fixes) then + declare + use Fix_Lists; + Fix : Fix_Type; + + It : Iterator := Iterate (Diag.Fixes); + begin + while Has_Next (It) loop + Next (It, Fix); + + Print_Fix (Fix, MAX_BAR_POS - 1); + end loop; + end; + end if; + + -- Separate main diagnostics with a blank line + + Write_Eol; + + end Print_Diagnostic; +end Diagnostics.Pretty_Emitter; diff --git a/gcc/ada/diagnostics-pretty_emitter.ads b/gcc/ada/diagnostics-pretty_emitter.ads new file mode 100644 index 0000000..5f46e34 --- /dev/null +++ b/gcc/ada/diagnostics-pretty_emitter.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . P R E T T Y _ E M I T T E R -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Pretty_Emitter is + procedure Print_Diagnostic (Diag : Diagnostic_Type); +end Diagnostics.Pretty_Emitter; diff --git a/gcc/ada/diagnostics-repository.adb b/gcc/ada/diagnostics-repository.adb new file mode 100644 index 0000000..dca38e9 --- /dev/null +++ b/gcc/ada/diagnostics-repository.adb @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . R E P O S I T O R Y -- +-- -- +-- 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.JSON_Utils; use Diagnostics.JSON_Utils; +with Diagnostics.Utils; use Diagnostics.Utils; +with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; +with Output; use Output; + +package body Diagnostics.Repository is + + --------------------------------- + -- Print_Diagnostic_Repository -- + --------------------------------- + + procedure Print_Diagnostic_Repository is + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_Str ("""" & "Diagnostics" & """" & ": " & "["); + Begin_Block; + + -- Avoid printing the first switch, which is a placeholder + + for I in Diagnostic_Entries'First .. Diagnostic_Entries'Last loop + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("Id", To_String (I)); + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Human_Id /= null then + Write_String_Attribute ("Human_Id", + Diagnostic_Entries (I).Human_Id.all); + else + Write_String_Attribute ("Human_Id", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Status = Active then + Write_String_Attribute ("Status", "Active"); + else + Write_String_Attribute ("Status", "Deprecated"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Documentation /= null then + Write_String_Attribute ("Documentation", + Diagnostic_Entries (I).Documentation.all); + else + Write_String_Attribute ("Documentation", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Switch /= No_Switch_Id then + Write_Char (','); + NL_And_Indent; + Write_String_Attribute + ("Switch", + Get_Switch (Diagnostic_Entries (I).Switch).Human_Id.all); + else + Write_String_Attribute ("Switch", "null"); + end if; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + Write_Eol; + end Print_Diagnostic_Repository; + +end Diagnostics.Repository; diff --git a/gcc/ada/diagnostics-repository.ads b/gcc/ada/diagnostics-repository.ads new file mode 100644 index 0000000..b070fda --- /dev/null +++ b/gcc/ada/diagnostics-repository.ads @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . R E P O S I T O R Y -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ +package Diagnostics.Repository is + + type Diagnostics_Registry_Type is + array (Diagnostic_Id) of Diagnostic_Entry_Type; + + -- Include the diagnostic entries for every diagnostic id. + -- The entries should include: + -- * Whether the diagnostic with this id is active or not + -- * The human-readable name for the diagnostic for SARIF reports + -- * The switch id for the diagnostic if the diagnostic is linked to any + -- compiler switch + -- * The documentation file for the diagnostic written in the MD format. + -- The documentation file should include: + -- - The diagnostic id + -- - A short description of the diagnostic + -- - A minimal example of the code that triggers the diagnostic + -- - An explanation of why the diagnostic was triggered + -- - A suggestion on how to fix the issue + -- - Optionally additional information + -- TODO: the mandatory fields for the documentation file could be changed + + Diagnostic_Entries : Diagnostics_Registry_Type := + (No_Diagnostic_Id => (others => <>), + GNAT0001 => + (Status => Active, + Human_Id => new String'("Default_Iterator_Not_Primitive_Error"), + Documentation => new String'("./error_codes/GNAT0001.md"), + Switch => No_Switch_Id), + GNAT0002 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_For_Operator_Error"), + Documentation => new String'("./error_codes/GNAT0002.md"), + Switch => No_Switch_Id), + GNAT0003 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Left_To_Int_Error"), + Documentation => new String'("./error_codes/GNAT0003.md"), + Switch => No_Switch_Id), + GNAT0004 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Right_To_Int_Error"), + Documentation => new String'("./error_codes/GNAT0004.md"), + Switch => No_Switch_Id), + GNAT0005 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Left_Acc_Error"), + Documentation => new String'("./error_codes/GNAT0005.md"), + Switch => No_Switch_Id), + GNAT0006 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Right_Acc_Error"), + Documentation => new String'("./error_codes/GNAT0006.md"), + Switch => No_Switch_Id), + GNAT0007 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_General_Error"), + Documentation => new String'("./error_codes/GNAT0007.md"), + Switch => No_Switch_Id), + GNAT0008 => + (Status => Active, + Human_Id => + new String'("Pragma_No_Effect_With_Lock_Free_Warning"), + Documentation => new String'("./error_codes/GNAT0008.md"), + Switch => No_Switch_Id), + GNAT0009 => + (Status => Active, + Human_Id => new String'("End_Loop_Expected_Error"), + Documentation => new String'("./error_codes/GNAT0009.md"), + Switch => No_Switch_Id), + GNAT0010 => + (Status => Active, + Human_Id => new String'("Representation_Too_Late_Error"), + Documentation => new String'("./error_codes/GNAT0010.md"), + Switch => No_Switch_Id)); + + procedure Print_Diagnostic_Repository; + +end Diagnostics.Repository; diff --git a/gcc/ada/diagnostics-sarif_emitter.adb b/gcc/ada/diagnostics-sarif_emitter.adb new file mode 100644 index 0000000..cbb423b --- /dev/null +++ b/gcc/ada/diagnostics-sarif_emitter.adb @@ -0,0 +1,1090 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . S A R I F _ E M I T T E R -- +-- -- +-- 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.Utils; use Diagnostics.Utils; +with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; +with Gnatvsn; use Gnatvsn; +with Output; use Output; +with Sinput; use Sinput; + +package body Diagnostics.SARIF_Emitter is + + type Artifact_Change is record + File : String_Ptr; + -- Name of the file + + Replacements : Edit_List; + -- Regions of texts to be edited + end record; + + procedure Destroy (Elem : in out Artifact_Change); + pragma Inline (Destroy); + + function Equals (L, R : Artifact_Change) return Boolean is + (L.File /= null + and then R.File /= null + and then L.File.all = R.File.all); + + package Artifact_Change_Lists is new Doubly_Linked_Lists + (Element_Type => Artifact_Change, + "=" => Equals, + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Artifact_Change_List is Artifact_Change_Lists.Doubly_Linked_List; + + function Get_Artifact_Changes (Fix : Fix_Type) return Artifact_Change_List; + -- Group edits of a Fix into Artifact_Changes that organize the edits by + -- file name. + + function Get_Unique_Rules (Diags : Diagnostic_List) return Diagnostic_List; + -- Get a list of diagnostics that have unique Diagnostic Id-s. + + procedure Print_Replacement (Replacement : Edit_Type); + -- Print a replacement node + -- + -- { + -- deletedRegion: {<Region>}, + -- insertedContent: {<Message>} + -- } + + procedure Print_Fix (Fix : Fix_Type); + -- Print the fix node + -- + -- { + -- description: {<Message>}, + -- artifactChanges: [<ArtifactChange>] + -- } + + procedure Print_Fixes (Diag : Diagnostic_Type); + -- Print the fixes node + -- + -- "fixes": [ + -- <Fix>, + -- ... + -- ] + + procedure Print_Artifact_Change (A : Artifact_Change); + -- Print an ArtifactChange node + -- + -- { + -- artifactLocation: {<ArtifactLocation>}, + -- replacements: [<Replacements>] + -- } + + procedure Print_Artifact_Location (File_Name : String); + -- Print an artifactLocation node + -- + -- "artifactLocation": { + -- "URI": <File_Name> + -- } + + procedure Print_Location (Loc : Labeled_Span_Type; + Msg : String_Ptr); + -- Print a location node that consists of + -- * an optional message node + -- * a physicalLocation node + -- * ArtifactLocation node that consists of the file name + -- * Region node that consists of the start and end positions of the span + -- + -- { + -- "message": { + -- "text": <Msg> + -- }, + -- "physicalLocation": { + -- "artifactLocation": { + -- "URI": <File_Name (Loc)> + -- }, + -- "region": { + -- "startLine": <Line(Loc.Fst)>, + -- "startColumn": <Col(Loc.Fst)>, + -- "endLine": <Line(Loc.Lst)>, + -- "endColumn": Col(Loc.Lst)> + -- } + -- } + -- } + + procedure Print_Locations (Diag : Diagnostic_Type); + -- Print a locations node that consists of multiple location nodes. However + -- typically just one location for the primary span of the diagnostic. + -- + -- "locations": [ + -- <Location (Primary_Span (Diag))> + -- ], + + procedure Print_Message (Text : String; Name : String := "message"); + -- Print a SARIF message node + -- + -- "message": { + -- "text": <text> + -- }, + + procedure Print_Related_Locations (Diag : Diagnostic_Type); + -- Print a relatedLocations node that consists of multiple location nodes. + -- Related locations are the non-primary spans of the diagnostic and the + -- primary locations of sub-diagnostics. + -- + -- "relatedLocations": [ + -- <Location (Diag.Loc)> + -- ], + + procedure Print_Region (Start_Line : Int; + Start_Col : Int; + End_Line : Int; + End_Col : Int; + Name : String := "region"); + -- Print a region node. + -- + -- More specifically a text region node that specifies the textual + -- location of the region. Note that in SARIF there are also binary + -- regions. + -- + -- "<Name>": { + -- "startLine": Start_Line, + -- "startColumn": Start_Col, + -- "endLine": End_Line, + -- "endColumn": End_Col + 1 + -- } + -- + -- Note that there are many types of nodes that can have a region type, + -- but have a different node name. + -- + -- The end column is defined differently in the SARIF report than it is + -- for the spans within GNAT. Internally we consider the end column of a + -- span to be the last character of the span. + -- + -- However in SARIF the end column is defined as: + -- "The column number of the character following the end of the region" + -- + -- This method assumes that the End_Col passed to this procedure is using + -- the GNAT span definition and we amend the endColumn value so that it + -- matches the SARIF definition. + + procedure Print_Result (Diag : Diagnostic_Type); + -- { + -- "ruleId": <Diag.Id>, + -- "level": <Diag.Kind>, + -- "message": { + -- "text": <Diag.Message> + -- }, + -- "locations": [<Primary_Location>], + -- "relatedLocations": [<Secondary_Locations>] + -- }, + + procedure Print_Results (Diags : Diagnostic_List); + -- Print a results node that consists of multiple result nodes for each + -- diagnostic instance. + -- + -- "results": [ + -- <Result (Diag)> + -- ] + + procedure Print_Rule (Diag : Diagnostic_Type); + -- Print a rule node that consists of the following attributes: + -- * ruleId + -- * level + -- * name + -- + -- { + -- "id": <Diag.Id>, + -- "level": <Diag.Kind>, + -- "name": <Human_Id(Diag)> + -- }, + + procedure Print_Rules (Diags : Diagnostic_List); + -- Print a rules node that consists of multiple rule nodes. + -- Rules are considered to be a set of unique diagnostics with the unique + -- id-s. + -- + -- "rules": [ + -- <Rule (Diag)> + -- ] + + procedure Print_Runs (Diags : Diagnostic_List); + -- Print a runs node that can consist of multiple run nodes. + -- However for our report it consists of a single run that consists of + -- * a tool node + -- * a results node + -- + -- { + -- "tool": { <Tool (Diags)> }, + -- "results": [<Results (Diags)>] + -- } + + procedure Print_Tool (Diags : Diagnostic_List); + -- Print a tool node that consists of + -- * a driver node that consists of: + -- * name + -- * version + -- * rules + -- + -- "tool": { + -- "driver": { + -- "name": "GNAT", + -- "version": <GNAT_Version>, + -- "rules": [<Rules (Diags)>] + -- } + -- } + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Artifact_Change) + is + + begin + Free (Elem.File); + end Destroy; + + -------------------------- + -- Get_Artifact_Changes -- + -------------------------- + + function Get_Artifact_Changes (Fix : Fix_Type) return Artifact_Change_List + is + procedure Insert (Changes : Artifact_Change_List; E : Edit_Type); + + ------------ + -- Insert -- + ------------ + + procedure Insert (Changes : Artifact_Change_List; E : Edit_Type) + is + A : Artifact_Change; + + It : Artifact_Change_Lists.Iterator := + Artifact_Change_Lists.Iterate (Changes); + begin + while Artifact_Change_Lists.Has_Next (It) loop + Artifact_Change_Lists.Next (It, A); + + if A.File.all = To_File_Name (E.Span.Ptr) then + Edit_Lists.Append (A.Replacements, E); + return; + end if; + end loop; + + declare + Replacements : constant Edit_List := Edit_Lists.Create; + begin + Edit_Lists.Append (Replacements, E); + Artifact_Change_Lists.Append + (Changes, + (File => new String'(To_File_Name (E.Span.Ptr)), + Replacements => Replacements)); + end; + end Insert; + + Changes : constant Artifact_Change_List := Artifact_Change_Lists.Create; + + E : Edit_Type; + + It : Edit_Lists.Iterator := Edit_Lists.Iterate (Fix.Edits); + begin + while Edit_Lists.Has_Next (It) loop + Edit_Lists.Next (It, E); + + Insert (Changes, E); + end loop; + + return Changes; + end Get_Artifact_Changes; + + ---------------------- + -- Get_Unique_Rules -- + ---------------------- + + function Get_Unique_Rules (Diags : Diagnostic_List) + return Diagnostic_List + is + use Diagnostics.Diagnostics_Lists; + + procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type); + + ------------ + -- Insert -- + ------------ + + procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type) is + It : Iterator := Iterate (Rules); + R : Diagnostic_Type; + begin + while Has_Next (It) loop + Next (It, R); + + if R.Id = D.Id then + return; + elsif R.Id > D.Id then + Insert_Before (Rules, R, D); + return; + end if; + end loop; + + Append (Rules, D); + end Insert; + + D : Diagnostic_Type; + Unique_Rules : constant Diagnostic_List := Create; + + It : Iterator := Iterate (Diags); + begin + if Present (Diags) then + while Has_Next (It) loop + Next (It, D); + Insert (Unique_Rules, D); + end loop; + end if; + + return Unique_Rules; + end Get_Unique_Rules; + + --------------------------- + -- Print_Artifact_Change -- + --------------------------- + + procedure Print_Artifact_Change (A : Artifact_Change) + is + use Diagnostics.Edit_Lists; + E : Edit_Type; + E_It : Iterator; + + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print artifactLocation + + Print_Artifact_Location (A.File.all); + + Write_Char (','); + NL_And_Indent; + + Write_Str ("""" & "replacements" & """" & ": " & "["); + Begin_Block; + NL_And_Indent; + + E_It := Iterate (A.Replacements); + + while Has_Next (E_It) loop + Next (E_It, E); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Replacement (E); + end loop; + + -- End replacements + + End_Block; + NL_And_Indent; + Write_Char (']'); + + -- End artifactChange + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Artifact_Change; + + ----------------------------- + -- Print_Artifact_Location -- + ----------------------------- + + procedure Print_Artifact_Location (File_Name : String) is + + begin + Write_Str ("""" & "artifactLocation" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("uri", File_Name); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Artifact_Location; + + ----------------------- + -- Print_Replacement -- + ----------------------- + + procedure Print_Replacement (Replacement : Edit_Type) is + -- Span start positions + Fst : constant Source_Ptr := Replacement.Span.First; + Line_Fst : constant Int := Int (Get_Physical_Line_Number (Fst)); + Col_Fst : constant Int := Int (Get_Column_Number (Fst)); + + -- Span end positions + Lst : constant Source_Ptr := Replacement.Span.Last; + Line_Lst : constant Int := Int (Get_Physical_Line_Number (Lst)); + Col_Lst : constant Int := Int (Get_Column_Number (Lst)); + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print deletedRegion + + Print_Region (Start_Line => Line_Fst, + Start_Col => Col_Fst, + End_Line => Line_Lst, + End_Col => Col_Lst, + Name => "deletedRegion"); + + if Replacement.Text /= null then + Write_Char (','); + NL_And_Indent; + + Print_Message (Replacement.Text.all, "insertedContent"); + end if; + + -- End replacement + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Replacement; + + --------------- + -- Print_Fix -- + --------------- + + procedure Print_Fix (Fix : Fix_Type) is + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print the message if the location has one + + if Fix.Description /= null then + Print_Message (Fix.Description.all, "description"); + + Write_Char (','); + NL_And_Indent; + end if; + + declare + use Artifact_Change_Lists; + Changes : Artifact_Change_List := Get_Artifact_Changes (Fix); + A : Artifact_Change; + A_It : Iterator := Iterate (Changes); + begin + Write_Str ("""" & "artifactChanges" & """" & ": " & "["); + Begin_Block; + + while Has_Next (A_It) loop + Next (A_It, A); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + + Print_Artifact_Change (A); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + Destroy (Changes); + end; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Fix; + + ----------------- + -- Print_Fixes -- + ----------------- + + procedure Print_Fixes (Diag : Diagnostic_Type) is + use Diagnostics.Fix_Lists; + F : Fix_Type; + F_It : Iterator; + + First : Boolean := True; + begin + Write_Str ("""" & "fixes" & """" & ": " & "["); + Begin_Block; + + if Present (Diag.Fixes) then + F_It := Iterate (Diag.Fixes); + while Has_Next (F_It) loop + Next (F_It, F); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Fix (F); + end loop; + end if; + + End_Block; + NL_And_Indent; + Write_Char (']'); + end Print_Fixes; + + ------------------ + -- Print_Region -- + ------------------ + + procedure Print_Region (Start_Line : Int; + Start_Col : Int; + End_Line : Int; + End_Col : Int; + Name : String := "region") + is + + begin + Write_Str ("""" & Name & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + Write_Int_Attribute ("startLine", Start_Line); + Write_Char (','); + NL_And_Indent; + + Write_Int_Attribute ("startColumn", Start_Col); + Write_Char (','); + NL_And_Indent; + + Write_Int_Attribute ("endLine", End_Line); + Write_Char (','); + NL_And_Indent; + + -- Convert the end of the span to the definition of the endColumn + -- for a SARIF region. + + Write_Int_Attribute ("endColumn", End_Col + 1); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Region; + + -------------------- + -- Print_Location -- + -------------------- + + procedure Print_Location (Loc : Labeled_Span_Type; + Msg : String_Ptr) + is + + -- Span start positions + Fst : constant Source_Ptr := Loc.Span.First; + Line_Fst : constant Int := Int (Get_Physical_Line_Number (Fst)); + Col_Fst : constant Int := Int (Get_Column_Number (Fst)); + + -- Span end positions + Lst : constant Source_Ptr := Loc.Span.Last; + Line_Lst : constant Int := Int (Get_Physical_Line_Number (Lst)); + Col_Lst : constant Int := Int (Get_Column_Number (Lst)); + + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print the message if the location has one + + if Msg /= null then + Print_Message (Msg.all); + + Write_Char (','); + NL_And_Indent; + end if; + + Write_Str ("""" & "physicalLocation" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + -- Print artifactLocation + + Print_Artifact_Location (To_File_Name (Loc.Span.Ptr)); + + Write_Char (','); + NL_And_Indent; + + -- Print region + + Print_Region (Start_Line => Line_Fst, + Start_Col => Col_Fst, + End_Line => Line_Lst, + End_Col => Col_Lst); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Location; + + --------------------- + -- Print_Locations -- + --------------------- + + procedure Print_Locations (Diag : Diagnostic_Type) is + use Diagnostics.Labeled_Span_Lists; + Loc : Labeled_Span_Type; + It : Iterator := Iterate (Diag.Locations); + + First : Boolean := True; + begin + Write_Str ("""" & "locations" & """" & ": " & "["); + Begin_Block; + + while Has_Next (It) loop + Next (It, Loc); + + -- Only the primary span is considered as the main location other + -- spans are considered related locations + + if Loc.Is_Primary then + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Location (Loc, Loc.Label); + end if; + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + end Print_Locations; + + ------------------- + -- Print_Message -- + ------------------- + + procedure Print_Message (Text : String; Name : String := "message") is + + begin + Write_Str ("""" & Name & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + Write_String_Attribute ("text", Text); + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Message; + + ----------------------------- + -- Print_Related_Locations -- + ----------------------------- + + procedure Print_Related_Locations (Diag : Diagnostic_Type) is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Diag.Locations); + + Sub : Sub_Diagnostic_Type; + Sub_It : Sub_Diagnostic_Lists.Iterator; + + First : Boolean := True; + begin + Write_Str ("""" & "relatedLocations" & """" & ": " & "["); + Begin_Block; + + -- Related locations are the non-primary spans of the diagnostic + + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + -- Non-primary spans are considered related locations + + if not Loc.Is_Primary then + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Location (Loc, Loc.Label); + end if; + end loop; + + -- And the sub-diagnostic locations + + if Sub_Diagnostic_Lists.Present (Diag.Sub_Diagnostics) then + Sub_It := Sub_Diagnostic_Lists.Iterate (Diag.Sub_Diagnostics); + + while Sub_Diagnostic_Lists.Has_Next (Sub_It) loop + Sub_Diagnostic_Lists.Next (Sub_It, Sub); + + declare + Found : Boolean := False; + + Prim_Loc : Labeled_Span_Type; + begin + if Labeled_Span_Lists.Present (Sub.Locations) then + Loc_It := Labeled_Span_Lists.Iterate (Sub.Locations); + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + -- For sub-diagnostic locations, only the primary span is + -- considered. + + if not Found and then Loc.Is_Primary then + Found := True; + Prim_Loc := Loc; + end if; + end loop; + else + + -- If there are no locations for the sub-diagnostic then use + -- the primary location of the main diagnostic. + + Found := True; + Prim_Loc := Primary_Location (Diag); + end if; + + -- For mapping sub-diagnostics to related locations we have to + -- make some compromises in details. + -- + -- Firstly we only make one entry that is for the primary span + -- of the sub-diagnostic. + -- + -- Secondly this span can also have a label. However this + -- pattern is not advised and by default we include the message + -- of the sub-diagnostic as the message in location node since + -- it should have more information. + + if Found then + if First then + First := False; + else + Write_Char (','); + end if; + NL_And_Indent; + Print_Location (Prim_Loc, Sub.Message); + end if; + end; + end loop; + end if; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + end Print_Related_Locations; + + ------------------ + -- Print_Result -- + ------------------ + + procedure Print_Result (Diag : Diagnostic_Type) is + + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print ruleId + + Write_String_Attribute ("ruleId", "[" & To_String (Diag.Id) & "]"); + + Write_Char (','); + NL_And_Indent; + + -- Print level + + Write_String_Attribute ("level", Kind_To_String (Diag)); + + Write_Char (','); + NL_And_Indent; + + -- Print message + + Print_Message (Diag.Message.all); + + Write_Char (','); + NL_And_Indent; + + -- Print locations + + Print_Locations (Diag); + + Write_Char (','); + NL_And_Indent; + + -- Print related locations + + Print_Related_Locations (Diag); + + Write_Char (','); + NL_And_Indent; + + -- Print fixes + + Print_Fixes (Diag); + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + end Print_Result; + + ------------------- + -- Print_Results -- + ------------------- + + procedure Print_Results (Diags : Diagnostic_List) is + use Diagnostics.Diagnostics_Lists; + + D : Diagnostic_Type; + + It : Iterator := Iterate (All_Diagnostics); + + First : Boolean := True; + begin + Write_Str ("""" & "results" & """" & ": " & "["); + Begin_Block; + + if Present (Diags) then + while Has_Next (It) loop + Next (It, D); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Result (D); + end loop; + end if; + + End_Block; + NL_And_Indent; + Write_Char (']'); + end Print_Results; + + ---------------- + -- Print_Rule -- + ---------------- + + procedure Print_Rule (Diag : Diagnostic_Type) is + Human_Id : constant String_Ptr := Get_Human_Id (Diag); + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("id", "[" & To_String (Diag.Id) & "]"); + Write_Char (','); + NL_And_Indent; + + Write_String_Attribute ("level", Kind_To_String (Diag)); + Write_Char (','); + NL_And_Indent; + + if Human_Id = null then + Write_String_Attribute ("name", "Uncategorized_Diagnostic"); + else + Write_String_Attribute ("name", Human_Id.all); + end if; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Rule; + + ----------------- + -- Print_Rules -- + ----------------- + + procedure Print_Rules (Diags : Diagnostic_List) is + use Diagnostics.Diagnostics_Lists; + + R : Diagnostic_Type; + Rules : constant Diagnostic_List := Get_Unique_Rules (Diags); + + It : Iterator := Iterate (Rules); + + First : Boolean := True; + begin + Write_Str ("""" & "rules" & """" & ": " & "["); + Begin_Block; + + while Has_Next (It) loop + Next (It, R); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Rule (R); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + end Print_Rules; + + ---------------- + -- Print_Tool -- + ---------------- + + procedure Print_Tool (Diags : Diagnostic_List) is + + begin + Write_Str ("""" & "tool" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + -- -- Attributes of tool + + Write_Str ("""" & "driver" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + -- Attributes of tool.driver + + Write_String_Attribute ("name", "GNAT"); + Write_Char (','); + NL_And_Indent; + + Write_String_Attribute ("version", Gnat_Version_String); + Write_Char (','); + NL_And_Indent; + + Print_Rules (Diags); + + -- End of tool.driver + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + + -- End of tool + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + end Print_Tool; + + ---------------- + -- Print_Runs -- + ---------------- + + procedure Print_Runs (Diags : Diagnostic_List) is + + begin + Write_Str ("""" & "runs" & """" & ": " & "["); + Begin_Block; + NL_And_Indent; + + -- Runs can consist of multiple "run"-s. However the GNAT SARIF report + -- only has one. + + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- A run consists of a tool + + Print_Tool (Diags); + + Write_Char (','); + NL_And_Indent; + + -- A run consists of results + + Print_Results (Diags); + + -- End of run + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + + End_Block; + NL_And_Indent; + + -- End of runs + + Write_Char (']'); + end Print_Runs; + + ------------------------ + -- Print_SARIF_Report -- + ------------------------ + + procedure Print_SARIF_Report (Diags : Diagnostic_List) is + + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("version", "2.1.0"); + Write_Char (','); + NL_And_Indent; + + Print_Runs (Diags); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + Write_Eol; + end Print_SARIF_Report; + +end Diagnostics.SARIF_Emitter; diff --git a/gcc/ada/diagnostics-sarif_emitter.ads b/gcc/ada/diagnostics-sarif_emitter.ads new file mode 100644 index 0000000..3d9bbae --- /dev/null +++ b/gcc/ada/diagnostics-sarif_emitter.ads @@ -0,0 +1,29 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . S A R I F _ E M I T T E R -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.SARIF_Emitter is + + procedure Print_SARIF_Report (Diags : Diagnostic_List); +end Diagnostics.SARIF_Emitter; diff --git a/gcc/ada/diagnostics-switch_repository.adb b/gcc/ada/diagnostics-switch_repository.adb new file mode 100644 index 0000000..d609901 --- /dev/null +++ b/gcc/ada/diagnostics-switch_repository.adb @@ -0,0 +1,688 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . D I A G N O S T I C S _ R E P O S I T O R Y -- +-- -- +-- 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.JSON_Utils; use Diagnostics.JSON_Utils; +with Output; use Output; +package body Diagnostics.Switch_Repository is + + Switches : constant array (Switch_Id) + of Switch_Type := + (No_Switch_Id => + (others => <>), + gnatwb => + (Human_Id => new String'("Warn_On_Bad_Fixed_Value"), + Status => Active, + Short_Name => new String'("gnatwb"), + Description => null, + Documentation_Url => null), + gnatwc => + (Human_Id => new String'("Constant_Condition_Warnings"), + Status => Active, + Short_Name => new String'("gnatwc"), + Description => null, + Documentation_Url => null), + gnatwd => + -- TODO: is this a subcheck of general gnatwu? + (Human_Id => new String'("Warn_On_Dereference"), + Status => Active, + Short_Name => new String'("gnatwd"), + Description => null, + Documentation_Url => null), + gnatwf => + (Human_Id => new String'("Check_Unreferenced_Formals"), + Status => Active, + Short_Name => new String'("gnatwf"), + Description => null, + Documentation_Url => null), + gnatwg => + (Human_Id => new String'("Warn_On_Unrecognized_Pragma"), + Status => Active, + Short_Name => new String'("gnatwg"), + Description => null, + Documentation_Url => null), + gnatwh => + (Human_Id => new String'("Warn_On_Hiding"), + Status => Active, + Short_Name => new String'("gnatwh"), + Description => null, + Documentation_Url => null), + gnatwi => + (Human_Id => new String'("Implementation_Unit_Warnings"), + Status => Active, + Short_Name => new String'("gnatwi"), + Description => null, + Documentation_Url => null), + gnatwj => + (Human_Id => new String'("Warn_On_Obsolescent_Feature"), + Status => Active, + Short_Name => new String'("gnatwj"), + Description => null, + Documentation_Url => null), + gnatwk => + (Human_Id => new String'("Warn_On_Constant"), + Status => Active, + Short_Name => new String'("gnatwk"), + Description => null, + Documentation_Url => null), + gnatwl => + (Human_Id => new String'("Elab_Warnings"), + Status => Active, + Short_Name => new String'("gnatwl"), + Description => null, + Documentation_Url => null), + gnatwm => + (Human_Id => new String'("Warn_On_Modified_Unread"), + Status => Active, + Short_Name => new String'("gnatwm"), + Description => null, + Documentation_Url => null), + gnatwo => + (Human_Id => new String'("Address_Clause_Overlay_Warnings"), + Status => Active, + Short_Name => new String'("gnatwo"), + Description => null, + Documentation_Url => null), + gnatwp => + (Human_Id => new String'("Ineffective_Inline_Warnings"), + Status => Active, + Short_Name => new String'("gnatwp"), + Description => null, + Documentation_Url => null), + gnatwq => + (Human_Id => new String'("Warn_On_Questionable_Missing_Parens"), + Status => Active, + Short_Name => new String'("gnatwq"), + Description => null, + Documentation_Url => null), + gnatwr => + (Human_Id => new String'("Warn_On_Redundant_Constructs"), + Status => Active, + Short_Name => new String'("gnatwr"), + Description => null, + Documentation_Url => null), + gnatwt => + (Human_Id => new String'("Warn_On_Deleted_Code"), + Status => Active, + Short_Name => new String'("gnatwt"), + Description => null, + Documentation_Url => null), + gnatwu => + (Human_Id => new String'("Warn_On_Unused_Entities"), + Status => Active, + Short_Name => new String'("gnatwu"), + Description => null, + Documentation_Url => null), + gnatwv => + (Human_Id => new String'("Warn_On_No_Value_Assigned"), + Status => Active, + Short_Name => new String'("gnatwv"), + Description => null, + Documentation_Url => null), + gnatww => + (Human_Id => new String'("Warn_On_Assumed_Low_Bound"), + Status => Active, + Short_Name => new String'("gnatww"), + Description => null, + Documentation_Url => null), + gnatwx => + (Human_Id => new String'("Warn_On_Export_Import"), + Status => Active, + Short_Name => new String'("gnatwx"), + Description => null, + Documentation_Url => null), + gnatwy => + (Human_Id => new String'("Warn_On_Ada_Compatibility_Issues"), + Status => Active, + Short_Name => new String'("gnatwy"), + Description => null, + Documentation_Url => null), + gnatwz => + (Human_Id => new String'("Warn_On_Unchecked_Conversion"), + Status => Active, + Short_Name => new String'("gnatwz"), + Description => null, + Documentation_Url => null), + gnatw_dot_a => + (Human_Id => new String'("Warn_On_Assertion_Failure"), + Status => Active, + Short_Name => new String'("gnatw.a"), + Description => null, + Documentation_Url => null), + gnatw_dot_b => + (Human_Id => new String'("Warn_On_Biased_Representation"), + Status => Active, + Short_Name => new String'("gnatw.b"), + Description => null, + Documentation_Url => null), + gnatw_dot_c => + (Human_Id => new String'("Warn_On_Unrepped_Components"), + Status => Active, + Short_Name => new String'("gnatw.c"), + Description => null, + Documentation_Url => null), + gnatw_dot_f => + (Human_Id => new String'("Warn_On_Elab_Access"), + Status => Active, + Short_Name => new String'("gnatw.f"), + Description => null, + Documentation_Url => null), + gnatw_dot_h => + (Human_Id => new String'("Warn_On_Record_Holes"), + Status => Active, + Short_Name => new String'("gnatw.h"), + Description => null, + Documentation_Url => null), + gnatw_dot_i => + (Human_Id => new String'("Warn_On_Overlap"), + Status => Active, + Short_Name => new String'("gnatw.i"), + Description => null, + Documentation_Url => null), + gnatw_dot_j => + (Human_Id => new String'("Warn_On_Late_Primitives"), + Status => Active, + Short_Name => new String'("gnatw.j"), + Description => null, + Documentation_Url => null), + gnatw_dot_k => + (Human_Id => new String'("Warn_On_Standard_Redefinition"), + Status => Active, + Short_Name => new String'("gnatw.k"), + Description => null, + Documentation_Url => null), + gnatw_dot_l => + (Human_Id => new String'("List_Inherited_Aspects"), + Status => Active, + Short_Name => new String'("gnatw.l"), + Description => null, + Documentation_Url => null), + gnatw_dot_m => + (Human_Id => new String'("Warn_On_Suspicious_Modulus_Value"), + Status => Active, + Short_Name => new String'("gnatw.m"), + Description => null, + Documentation_Url => null), + gnatw_dot_n => + (Human_Id => new String'("Warn_On_Atomic_Synchronization"), + Status => Active, + Short_Name => new String'("gnatw.n"), + Description => null, + Documentation_Url => null), + gnatw_dot_o => + (Human_Id => new String'("Warn_On_All_Unread_Out_Parameters"), + Status => Active, + Short_Name => new String'("gnatw.o"), + Description => null, + Documentation_Url => null), + gnatw_dot_p => + (Human_Id => new String'("Warn_On_Parameter_Order"), + Status => Active, + Short_Name => new String'("gnatw.p"), + Description => null, + Documentation_Url => null), + gnatw_dot_q => + (Human_Id => new String'("Warn_On_Questionable_Layout"), + Status => Active, + Short_Name => new String'("gnatw.q"), + Description => null, + Documentation_Url => null), + gnatw_dot_r => + (Human_Id => new String'("Warn_On_Object_Renames_Function"), + Status => Active, + Short_Name => new String'("gnatw.r"), + Description => null, + Documentation_Url => null), + gnatw_dot_s => + (Human_Id => new String'("Warn_On_Overridden_Size"), + Status => Active, + Short_Name => new String'("gnatw.s"), + Description => null, + Documentation_Url => null), + gnatw_dot_t => + (Human_Id => new String'("Warn_On_Suspicious_Contract"), + Status => Active, + Short_Name => new String'("gnatw.t"), + Description => null, + Documentation_Url => null), + gnatw_dot_u => + (Human_Id => new String'("Warn_On_Unordered_Enumeration_Type"), + Status => Active, + Short_Name => new String'("gnatw.u"), + Description => null, + Documentation_Url => null), + gnatw_dot_v => + (Human_Id => new String'("Warn_On_Reverse_Bit_Order"), + Status => Active, + Short_Name => new String'("gnatw.v"), + Description => null, + Documentation_Url => null), + gnatw_dot_w => + (Human_Id => new String'("Warn_On_Warnings_Off"), + Status => Active, + Short_Name => new String'("gnatw.w"), + Description => null, + Documentation_Url => null), + gnatw_dot_x => + (Human_Id => + new String'("Warn_No_Exception_Propagation_Active"), + Status => Active, + Short_Name => new String'("gnatw.x"), + Description => null, + Documentation_Url => null), + gnatw_dot_y => + (Human_Id => new String'("List_Body_Required_Info"), + Status => Active, + Short_Name => new String'("gnatw.y"), + Description => null, + Documentation_Url => null), + gnatw_dot_z => + (Human_Id => new String'("Warn_On_Size_Alignment"), + Status => Active, + Short_Name => new String'("gnatw.z"), + Description => null, + Documentation_Url => null), + gnatw_underscore_a => + (Human_Id => new String'("Warn_On_Anonymous_Allocators"), + Status => Active, + Short_Name => new String'("gnatw_a"), + Description => null, + Documentation_Url => null), + gnatw_underscore_c => + (Human_Id => new String'("Warn_On_Unknown_Compile_Time_Warning"), + Status => Active, + Short_Name => new String'("gnatw_c"), + Description => null, + Documentation_Url => null), + gnatw_underscore_j => + (Human_Id => new String'("Warn_On_Non_Dispatching_Primitives"), + Status => Active, + Short_Name => new String'("gnatw_j"), + Description => null, + Documentation_Url => null), + gnatw_underscore_l => + (Human_Id => new String'("Warn_On_Inherently_Limited_Types"), + Status => Active, + Short_Name => new String'("gnatw_l"), + Description => null, + Documentation_Url => null), + gnatw_underscore_p => + (Human_Id => new String'("Warn_On_Pedantic_Checks"), + Status => Active, + Short_Name => new String'("gnatw_p"), + Description => null, + Documentation_Url => null), + gnatw_underscore_q => + (Human_Id => new String'("Warn_On_Ignored_Equality"), + Status => Active, + Short_Name => new String'("gnatw_q"), + Description => null, + Documentation_Url => null), + gnatw_underscore_r => + (Human_Id => new String'("Warn_On_Component_Order"), + Status => Active, + Short_Name => new String'("gnatw_r"), + Description => null, + Documentation_Url => null), + gnatw_underscore_s => + (Human_Id => new String'("Warn_On_Ineffective_Predicate_Test"), + Status => Active, + Short_Name => new String'("gnatw_s"), + Description => null, + Documentation_Url => null), + -- NOTE: this flag is usually followed by a number specfifying the + -- indentation level. We encode all of these warnings as -gnaty0 + -- irregardless of the actual numeric value. + gnaty => + (Human_Id => new String'("Style_Check_Indentation_Level"), + Status => Active, + Short_Name => new String'("gnaty0"), + Description => null, + Documentation_Url => null), + gnatya => + (Human_Id => new String'("Style_Check_Attribute_Casing"), + Status => Active, + Short_Name => new String'("gnatya"), + Description => null, + Documentation_Url => null), + gnatyaa => + (Human_Id => new String'("Address_Clause_Overlay_Warnings"), + Status => Active, + Short_Name => new String'("gnatyA"), + Description => null, + Documentation_Url => null), + gnatyb => + (Human_Id => new String'("Style_Check_Blanks_At_End"), + Status => Active, + Short_Name => new String'("gnatyb"), + Description => null, + Documentation_Url => null), + gnatybb => + -- NOTE: in live documentation it is called "Check Boolean operators" + (Human_Id => new String'("Style_Check_Boolean_And_Or"), + Status => Active, + Short_Name => new String'("gnatyB"), + Description => null, + Documentation_Url => null), + gnatyc => + (Human_Id => new String'("Style_Check_Comments_Double_Space"), + Status => Active, + Short_Name => new String'("gnatyc"), + Description => null, + Documentation_Url => null), + gnatycc => + (Human_Id => new String'("Style_Check_Comments_Single_Space"), + Status => Active, + Short_Name => new String'("gnatyC"), + Description => null, + Documentation_Url => null), + gnatyd => + (Human_Id => new String'("Style_Check_DOS_Line_Terminator"), + Status => Active, + Short_Name => new String'("gnatyd"), + Description => null, + Documentation_Url => null), + gnatydd => + (Human_Id => new String'("Style_Check_Mixed_Case_Decls"), + Status => Active, + Short_Name => new String'("gnatyD"), + Description => null, + Documentation_Url => null), + gnatye => + (Human_Id => new String'("Style_Check_End_Labels"), + Status => Active, + Short_Name => new String'("gnatye"), + Description => null, + Documentation_Url => null), + gnatyf => + (Human_Id => new String'("Style_Check_Form_Feeds"), + Status => Active, + Short_Name => new String'("gnatyf"), + Description => null, + Documentation_Url => null), + gnatyh => + (Human_Id => new String'("Style_Check_Horizontal_Tabs"), + Status => Active, + Short_Name => new String'("gnatyh"), + Description => null, + Documentation_Url => null), + gnatyi => + (Human_Id => new String'("Style_Check_If_Then_Layout"), + Status => Active, + Short_Name => new String'("gnatyi"), + Description => null, + Documentation_Url => null), + gnatyii => + (Human_Id => new String'("Style_Check_Mode_In"), + Status => Active, + Short_Name => new String'("gnatyI"), + Description => null, + Documentation_Url => null), + gnatyk => + (Human_Id => new String'("Style_Check_Keyword_Casing"), + Status => Active, + Short_Name => new String'("gnatyk"), + Description => null, + Documentation_Url => null), + gnatyl => + (Human_Id => new String'("Style_Check_Layout"), + Status => Active, + Short_Name => new String'("gnatyl"), + Description => null, + Documentation_Url => null), + gnatyll => + (Human_Id => new String'("Style_Check_Max_Nesting_Level"), + Status => Active, + Short_Name => new String'("gnatyL"), + Description => null, + Documentation_Url => null), + gnatym => + (Human_Id => new String'("Style_Check_Max_Line_Length"), + Status => Active, + Short_Name => new String'("gnatym"), + Description => null, + Documentation_Url => null), + gnatymm => + -- TODO: May contain line length + (Human_Id => new String'("Style_Check_Max_Line_Length"), + Status => Active, + Short_Name => new String'("gnatyM"), + Description => null, + Documentation_Url => null), + gnatyn => + (Human_Id => new String'("Style_Check_Standard"), + Status => Active, + Short_Name => new String'("gnatyn"), + Description => null, + Documentation_Url => null), + gnatyo => + (Human_Id => new String'("Style_Check_Order_Subprograms"), + Status => Active, + Short_Name => new String'("gnatyo"), + Description => null, + Documentation_Url => null), + gnatyoo => + (Human_Id => new String'("Style_Check_Missing_Overriding"), + Status => Active, + Short_Name => new String'("gnatyO"), + Description => null, + Documentation_Url => null), + gnatyp => + (Human_Id => new String'("Style_Check_Pragma_Casing"), + Status => Active, + Short_Name => new String'("gnatyp"), + Description => null, + Documentation_Url => null), + gnatyr => + (Human_Id => new String'("Style_Check_References"), + Status => Active, + Short_Name => new String'("gnatyr"), + Description => null, + Documentation_Url => null), + gnatys => + (Human_Id => new String'("Style_Check_Specs"), + Status => Active, + Short_Name => new String'("gnatys"), + Description => null, + Documentation_Url => null), + gnatyss => + (Human_Id => new String'("Style_Check_Separate_Stmt_Lines"), + Status => Active, + Short_Name => new String'("gnatyS"), + Description => null, + Documentation_Url => null), + gnatytt => + (Human_Id => new String'("Style_Check_Tokens"), + Status => Active, + Short_Name => new String'("gnatyt"), + Description => null, + Documentation_Url => null), + gnatyu => + (Human_Id => new String'("Style_Check_Blank_Lines"), + Status => Active, + Short_Name => new String'("gnatyu"), + Description => null, + Documentation_Url => null), + gnatyx => + (Human_Id => new String'("Style_Check_Xtra_Parens"), + Status => Active, + Short_Name => new String'("gnatyx"), + Description => null, + Documentation_Url => null), + gnatyz => + (Human_Id => new String'("Style_Check_Xtra_Parens_Precedence"), + Status => Active, + Short_Name => new String'("gnatyz"), + Description => null, + Documentation_Url => null), + gnatel => + (Human_Id => new String'("Display_Elaboration_Messages"), + Status => Active, + Short_Name => new String'("gnatel"), + Description => null, + Documentation_Url => null) + ); + + ---------------- + -- Get_Switch -- + ---------------- + + function Get_Switch (Id : Switch_Id) return Switch_Type is + + begin + return Switches (Id); + end Get_Switch; + + function Get_Switch (Diag : Diagnostic_Type) return Switch_Type is + + begin + return Get_Switch (Diag.Switch); + end Get_Switch; + + ------------------- + -- Get_Switch_Id -- + ------------------- + + function Get_Switch_Id (Name : String) return Switch_Id is + Trimmed_Name : constant String := + (if Name (Name'Last) = ' ' then Name (Name'First .. Name'Last - 1) + else Name); + begin + for I in Active_Switch_Id loop + if Switches (I).Short_Name.all = Trimmed_Name then + return I; + end if; + end loop; + + return No_Switch_Id; + end Get_Switch_Id; + + ------------------- + -- Get_Switch_Id -- + ------------------- + + function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is + + begin + if E.Warn_Chr = "$ " then + return Get_Switch_Id ("gnatel"); + elsif E.Warn or E.Info then + return Get_Switch_Id ("gnatw" & E.Warn_Chr); + elsif E.Style then + return Get_Switch_Id ("gnaty" & E.Warn_Chr); + else + return No_Switch_Id; + end if; + end Get_Switch_Id; + + ----------------------------- + -- Print_Switch_Repository -- + ----------------------------- + + procedure Print_Switch_Repository is + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_Str ("""" & "Switches" & """" & ": " & "["); + Begin_Block; + + -- Avoid printing the first switch, which is a placeholder + + for I in Active_Switch_Id loop + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + if Switches (I).Human_Id /= null then + Write_String_Attribute ("Human_Id", Switches (I).Human_Id.all); + else + Write_String_Attribute ("Human_Id", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Short_Name /= null then + Write_String_Attribute ("Short_Name", Switches (I).Short_Name.all); + else + Write_String_Attribute ("Short_Name", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Status = Active then + Write_String_Attribute ("Status", "Active"); + else + Write_String_Attribute ("Status", "Deprecated"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Description /= null then + Write_String_Attribute ("Description", + Switches (I).Description.all); + else + Write_String_Attribute ("Description", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Description /= null then + Write_String_Attribute ("Documentation_Url", + Switches (I).Description.all); + else + Write_String_Attribute ("Documentation_Url", "null"); + end if; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + Write_Eol; + end Print_Switch_Repository; + +end Diagnostics.Switch_Repository; diff --git a/gcc/ada/diagnostics-switch_repository.ads b/gcc/ada/diagnostics-switch_repository.ads new file mode 100644 index 0000000..5bd2d51 --- /dev/null +++ b/gcc/ada/diagnostics-switch_repository.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . D I A G N O S T I C S _ R E P O S I T O R Y -- +-- -- +-- S p e c -- +-- -- +-- 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 Erroutc; use Erroutc; + +package Diagnostics.Switch_Repository is + + function Get_Switch (Id : Switch_Id) return Switch_Type; + + function Get_Switch (Diag : Diagnostic_Type) return Switch_Type; + + function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id; + + function Get_Switch_Id (Name : String) return Switch_Id; + + procedure Print_Switch_Repository; + +end Diagnostics.Switch_Repository; 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; diff --git a/gcc/ada/diagnostics-utils.ads b/gcc/ada/diagnostics-utils.ads new file mode 100644 index 0000000..caf01ab --- /dev/null +++ b/gcc/ada/diagnostics-utils.ads @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . U T I L S -- +-- -- +-- S p e c -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Utils is + + function Get_Human_Id (D : Diagnostic_Type) return String_Ptr; + + function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String; + -- Convert the source pointer to a string and prefix it with the correct + -- preposition. + -- + -- * If the location is in one of the standard locations, + -- then it yields "in package <LOCATION>". The explicit standard + -- locations are: + -- * System + -- * Standard + -- * Standard.ASCII + -- * if the location is missing the the sloc yields "at unknown location" + -- * if the location is in the same file as the current file, + -- then it yields "at line <line>". + -- * Otherwise sloc yields "at <file>:<line>:<column>" + + function Sloc_To_String (N : Node_Or_Entity_Id; + Ref : Source_Ptr) + return String; + -- Converts the Sloc of the node or entity to a Sloc string. + + 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. + + function To_Full_Span (N : Node_Id) return Source_Span; + + function To_String (Id : Diagnostic_Id) return String; + -- Convert the diagnostic ID to a 4 character string padded with 0-s. + + function To_Name (E : Entity_Id) return String; + + function To_Type_Name (E : Entity_Id) return String; + + function Kind_To_String (D : Diagnostic_Type) return String; + + function Kind_To_String + (D : Sub_Diagnostic_Type; + Parent : Diagnostic_Type) return String; + + function Get_Primary_Labeled_Span (Spans : Labeled_Span_List) + return Labeled_Span_Type; + + function Get_Doc_Switch (Diag : Diagnostic_Type) return String; + + function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean; + + function Appears_Before (P1, P2 : Source_Ptr) return Boolean; + + procedure Insert_Based_On_Location + (List : Diagnostic_List; + Diagnostic : Diagnostic_Type); + +end Diagnostics.Utils; diff --git a/gcc/ada/diagnostics.adb b/gcc/ada/diagnostics.adb new file mode 100644 index 0000000..8acc915 --- /dev/null +++ b/gcc/ada/diagnostics.adb @@ -0,0 +1,542 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C 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 Atree; use Atree; +with Debug; use Debug; +with Diagnostics.Brief_Emitter; +with Diagnostics.Pretty_Emitter; +with Diagnostics.Repository; use Diagnostics.Repository; +with Diagnostics.Utils; use Diagnostics.Utils; +with Lib; use Lib; +with Opt; use Opt; +with Sinput; use Sinput; +with Warnsw; + +package body Diagnostics is + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Labeled_Span_Type) is + begin + Free (Elem.Label); + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Sub_Diagnostic_Type) is + begin + Free (Elem.Message); + if Labeled_Span_Lists.Present (Elem.Locations) then + Labeled_Span_Lists.Destroy (Elem.Locations); + end if; + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Edit_Type) is + begin + Free (Elem.Text); + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Fix_Type) is + begin + Free (Elem.Description); + if Edit_Lists.Present (Elem.Edits) then + Edit_Lists.Destroy (Elem.Edits); + end if; + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Diagnostic_Type) is + begin + Free (Elem.Message); + if Labeled_Span_Lists.Present (Elem.Locations) then + Labeled_Span_Lists.Destroy (Elem.Locations); + end if; + if Sub_Diagnostic_Lists.Present (Elem.Sub_Diagnostics) then + Sub_Diagnostic_Lists.Destroy (Elem.Sub_Diagnostics); + end if; + if Fix_Lists.Present (Elem.Fixes) then + Fix_Lists.Destroy (Elem.Fixes); + end if; + end Destroy; + + ------------------ + -- Add_Location -- + ------------------ + + procedure Add_Location + (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type) + is + use Labeled_Span_Lists; + begin + if not Present (Diagnostic.Locations) then + Diagnostic.Locations := Create; + end if; + + Append (Diagnostic.Locations, Location); + end Add_Location; + + ---------------------- + -- Primary_Location -- + ---------------------- + + function Primary_Location + (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type + is + use Labeled_Span_Lists; + Loc : Labeled_Span_Type; + + It : Iterator := Iterate (Diagnostic.Locations); + begin + while Has_Next (It) loop + Next (It, Loc); + if Loc.Is_Primary then + return Loc; + end if; + end loop; + + return (others => <>); + end Primary_Location; + + ------------------ + -- Add_Location -- + ------------------ + + procedure Add_Location + (Diagnostic : in out Diagnostic_Type; Location : Labeled_Span_Type) + is + use Labeled_Span_Lists; + begin + if not Present (Diagnostic.Locations) then + Diagnostic.Locations := Create; + end if; + + Append (Diagnostic.Locations, Location); + end Add_Location; + + ------------------------ + -- Add_Sub_Diagnostic -- + ------------------------ + + procedure Add_Sub_Diagnostic + (Diagnostic : in out Diagnostic_Type; + Sub_Diagnostic : Sub_Diagnostic_Type) + is + use Sub_Diagnostic_Lists; + begin + if not Present (Diagnostic.Sub_Diagnostics) then + Diagnostic.Sub_Diagnostics := Create; + end if; + + Append (Diagnostic.Sub_Diagnostics, Sub_Diagnostic); + end Add_Sub_Diagnostic; + + procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type) is + use Edit_Lists; + begin + if not Present (Fix.Edits) then + Fix.Edits := Create; + end if; + + Append (Fix.Edits, Edit); + end Add_Edit; + + ------------- + -- Add_Fix -- + ------------- + + procedure Add_Fix (Diagnostic : in out Diagnostic_Type; Fix : Fix_Type) is + use Fix_Lists; + begin + if not Present (Diagnostic.Fixes) then + Diagnostic.Fixes := Create; + end if; + + Append (Diagnostic.Fixes, Fix); + end Add_Fix; + + ----------------------- + -- Record_Diagnostic -- + ----------------------- + + procedure Record_Diagnostic (Diagnostic : Diagnostic_Type; + Update_Count : Boolean := True) + is + + procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type); + + ----------------------------- + -- Update_Diagnostic_Count -- + ----------------------------- + + procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type) is + + begin + if Diagnostic.Kind = Error then + Total_Errors_Detected := Total_Errors_Detected + 1; + + if Diagnostic.Serious then + Serious_Errors_Detected := Serious_Errors_Detected + 1; + end if; + elsif Diagnostic.Kind in Warning | Style then + Warnings_Detected := Warnings_Detected + 1; + + if Diagnostic.Warn_Err then + Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; + end if; + elsif Diagnostic.Kind in Info then + Info_Messages := Info_Messages + 1; + end if; + end Update_Diagnostic_Count; + + procedure Handle_Serious_Error; + -- Internal procedure to do all error message handling for a serious + -- error message, other than bumping the error counts and arranging + -- for the message to be output. + + procedure Handle_Serious_Error is + begin + -- Turn off code generation if not done already + + if Operating_Mode = Generate_Code then + Operating_Mode := Check_Semantics; + Expander_Active := False; + end if; + + -- Set the fatal error flag in the unit table unless we are in + -- Try_Semantics mode (in which case we set ignored mode if not + -- currently set. This stops the semantics from being performed + -- if we find a serious error. This is skipped if we are currently + -- dealing with the configuration pragma file. + + if Current_Source_Unit /= No_Unit then + declare + U : constant Unit_Number_Type := + Get_Source_Unit + (Primary_Location (Diagnostic).Span.Ptr); + begin + if Try_Semantics then + if Fatal_Error (U) = None then + Set_Fatal_Error (U, Error_Ignored); + end if; + else + Set_Fatal_Error (U, Error_Detected); + end if; + end; + end if; + + -- Disable warnings on unused use clauses and the like. Otherwise, an + -- error might hide a reference to an entity in a used package, so + -- after fixing the error, the use clause no longer looks like it was + -- unused. + + Warnsw.Check_Unreferenced := False; + Warnsw.Check_Unreferenced_Formals := False; + end Handle_Serious_Error; + begin + Insert_Based_On_Location (All_Diagnostics, Diagnostic); + + if Update_Count then + Update_Diagnostic_Count (Diagnostic); + end if; + + if Diagnostic.Kind = Error and then Diagnostic.Serious then + Handle_Serious_Error; + end if; + end Record_Diagnostic; + + ---------------------- + -- Print_Diagnostic -- + ---------------------- + + procedure Print_Diagnostic (Diagnostic : Diagnostic_Type) is + + begin + if Debug_Flag_FF then + Diagnostics.Pretty_Emitter.Print_Diagnostic (Diagnostic); + else + Diagnostics.Brief_Emitter.Print_Diagnostic (Diagnostic); + end if; + end Print_Diagnostic; + + ---------------------- + -- Primary_Location -- + ---------------------- + + function Primary_Location + (Diagnostic : Diagnostic_Type) return Labeled_Span_Type + is + begin + return Get_Primary_Labeled_Span (Diagnostic.Locations); + end Primary_Location; + + --------------------- + -- Make_Diagnostic -- + --------------------- + + function Make_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes) + return Diagnostic_Type + is + D : Diagnostic_Type; + begin + D.Message := new String'(Msg); + D.Id := Id; + D.Kind := Kind; + + if Id /= No_Diagnostic_Id then + pragma Assert (Switch = Diagnostic_Entries (Id).Switch, + "Provided switch must be the same as in the registry"); + end if; + D.Switch := Switch; + + pragma Assert (Location.Is_Primary, "Main location must be primary"); + Add_Location (D, Location); + + for I in Spans'Range loop + Add_Location (D, Spans (I)); + end loop; + + for I in Sub_Diags'Range loop + Add_Sub_Diagnostic (D, Sub_Diags (I)); + end loop; + + for I in Fixes'Range loop + Add_Fix (D, Fixes (I)); + end loop; + + return D; + end Make_Diagnostic; + + ----------------------- + -- Record_Diagnostic -- + ----------------------- + + procedure Record_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes) + is + + begin + Record_Diagnostic + (Make_Diagnostic + (Msg => Msg, + Location => Location, + Id => Id, + Kind => Kind, + Switch => Switch, + Spans => Spans, + Sub_Diags => Sub_Diags, + Fixes => Fixes)); + end Record_Diagnostic; + + ------------------ + -- Labeled_Span -- + ------------------ + + function Labeled_Span (Span : Source_Span; + Label : String := ""; + Is_Primary : Boolean := True; + Is_Region : Boolean := False) + return Labeled_Span_Type + is + L : Labeled_Span_Type; + begin + L.Span := Span; + if Label /= "" then + L.Label := new String'(Label); + end if; + L.Is_Primary := Is_Primary; + L.Is_Region := Is_Region; + + return L; + end Labeled_Span; + + -------------------------- + -- Primary_Labeled_Span -- + -------------------------- + + function Primary_Labeled_Span (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type + is begin + return Labeled_Span (Span => Span, Label => Label, Is_Primary => True); + end Primary_Labeled_Span; + + -------------------------- + -- Primary_Labeled_Span -- + -------------------------- + + function Primary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type + is + begin + return Primary_Labeled_Span (To_Full_Span (N), Label); + end Primary_Labeled_Span; + + ---------------------------- + -- Secondary_Labeled_Span -- + ---------------------------- + + function Secondary_Labeled_Span + (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type + is + begin + return Labeled_Span (Span => Span, Label => Label, Is_Primary => False); + end Secondary_Labeled_Span; + + ---------------------------- + -- Secondary_Labeled_Span -- + ---------------------------- + + function Secondary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type + is + begin + return Secondary_Labeled_Span (To_Full_Span (N), Label); + end Secondary_Labeled_Span; + + -------------- + -- Sub_Diag -- + -------------- + + function Sub_Diag (Msg : String; + Kind : Sub_Diagnostic_Kind := + Diagnostics.Continuation; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + S : Sub_Diagnostic_Type; + begin + S.Message := new String'(Msg); + S.Kind := Kind; + + for I in Locations'Range loop + Add_Location (S, Locations (I)); + end loop; + + return S; + end Sub_Diag; + + ------------------ + -- Continuation -- + ------------------ + + function Continuation (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + begin + return Sub_Diag (Msg, Diagnostics.Continuation, Locations); + end Continuation; + + ---------- + -- Help -- + ---------- + + function Help (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + begin + return Sub_Diag (Msg, Diagnostics.Help, Locations); + end Help; + + ---------------- + -- Suggestion -- + ---------------- + + function Suggestion (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + begin + return Sub_Diag (Msg, Diagnostics.Suggestion, Locations); + end Suggestion; + + --------- + -- Fix -- + --------- + + function Fix + (Description : String; + Edits : Edit_Array; + Applicability : Applicability_Type := Unspecified) return Fix_Type + is + F : Fix_Type; + begin + F.Description := new String'(Description); + + for I in Edits'Range loop + Add_Edit (F, Edits (I)); + end loop; + + F.Applicability := Applicability; + + return F; + end Fix; + + ---------- + -- Edit -- + ---------- + + function Edit (Text : String; Span : Source_Span) return Edit_Type is + + begin + return (Text => new String'(Text), Span => Span); + end Edit; + +end Diagnostics; diff --git a/gcc/ada/diagnostics.ads b/gcc/ada/diagnostics.ads new file mode 100644 index 0000000..18afb1c --- /dev/null +++ b/gcc/ada/diagnostics.ads @@ -0,0 +1,481 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S -- +-- -- +-- S p e c -- +-- -- +-- 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 Types; use Types; +with GNAT.Lists; use GNAT.Lists; + +package Diagnostics is + + type Diagnostic_Id is + (No_Diagnostic_Id, + GNAT0001, + GNAT0002, + GNAT0003, + GNAT0004, + GNAT0005, + GNAT0006, + GNAT0007, + GNAT0008, + GNAT0009, + GNAT0010); + + -- Labeled_Span_Type represents a span of source code that is associated + -- with a textual label. Primary spans indicate the primary location of the + -- diagnostic. Non-primary spans are used to indicate secondary locations. + -- + -- Spans can contain labels that are used to annotate the highlighted span. + -- Usually, the label is a short and concise message that provide + -- additional allthough non-critical information about the span. This is + -- an important since labels are not printed in the brief output and are + -- only present in the pretty and structural outputs. That is an important + -- distintion when choosing between a label and a sub-diagnostic. + type Labeled_Span_Type is record + Label : String_Ptr := null; + -- Text associated with the span + + Span : Source_Span := (others => No_Location); + -- Textual region in the source code + + Is_Primary : Boolean := True; + -- Primary spans are used to indicate the primary location of the + -- diagnostic. Typically there should just be one primary span per + -- diagnostic. + -- Non-primary spans are used to indicate secondary locations and + -- typically are formatted in a different way or omitted in some + -- contexts. + + Is_Region : Boolean := False; + -- Regional spans are multiline spans that have a unique way of being + -- displayed in the pretty output. + end record; + + No_Labeled_Span : constant Labeled_Span_Type := (others => <>); + + procedure Destroy (Elem : in out Labeled_Span_Type); + pragma Inline (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 Sub_Diagnostic_Kind is + (Continuation, + Help, + Note, + Suggestion); + + -- Sub_Diagnostic_Type represents a sub-diagnostic message that is meant + -- to provide additional information about the primary diagnostic message. + -- + -- Sub-diagnostics are usually constructed with a full sentence as the + -- message and provide important context to the main diagnostic message or + -- some concrete action to the user. + -- + -- This is different from the labels of labeled spans which are meant to be + -- short and concise and are mostly there to annotate the higlighted span. + + type Sub_Diagnostic_Type is record + Kind : Sub_Diagnostic_Kind; + + Message : String_Ptr; + + Locations : Labeled_Span_List; + end record; + + procedure Add_Location + (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type); + + function Primary_Location + (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type; + + procedure Destroy (Elem : in out Sub_Diagnostic_Type); + pragma Inline (Destroy); + + package Sub_Diagnostic_Lists is new Doubly_Linked_Lists + (Element_Type => Sub_Diagnostic_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Sub_Diagnostic_List is Sub_Diagnostic_Lists.Doubly_Linked_List; + + -- An Edit_Type represents a textual edit that is associated with a Fix. + type Edit_Type is record + Span : Source_Span; + -- Region of the file to be removed + + Text : String_Ptr; + -- Text to be inserted at the start location of the span + end record; + + procedure Destroy (Elem : in out Edit_Type); + pragma Inline (Destroy); + + package Edit_Lists is new Doubly_Linked_Lists + (Element_Type => Edit_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Edit_List is Edit_Lists.Doubly_Linked_List; + + -- Type Applicability_Type will indicate the state of the resulting code + -- after applying a fix. + -- * Option Has_Placeholders indicates that the fix contains placeholders + -- that the user would need to fill. + -- * Option Legal indicates that applying the fix will result in legal Ada + -- code. + -- * Option Possibly_Illegal indicates that applying the fix will result in + -- possibly legal, but also possibly illegal Ada code. + type Applicability_Type is + (Has_Placeholders, + Legal, + Possibly_Illegal, + Unspecified); + + type Fix_Type is record + Description : String_Ptr := null; + -- Message describing the fix that will be displayed to the user. + + Applicability : Applicability_Type := Unspecified; + + Edits : Edit_List; + -- File changes for the fix. + end record; + + procedure Destroy (Elem : in out Fix_Type); + pragma Inline (Destroy); + + package Fix_Lists is new Doubly_Linked_Lists + (Element_Type => Fix_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Fix_List is Fix_Lists.Doubly_Linked_List; + + procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type); + + type Status_Type is + (Active, + Deprecated); + + type Switch_Id is ( + No_Switch_Id, + gnatwb, + gnatwc, + gnatwd, + gnatwf, + gnatwg, + gnatwh, + gnatwi, + gnatwj, + gnatwk, + gnatwl, + gnatwm, + gnatwo, + gnatwp, + gnatwq, + gnatwr, + gnatwt, + gnatwu, + gnatwv, + gnatww, + gnatwx, + gnatwy, + gnatwz, + gnatw_dot_a, + gnatw_dot_b, + gnatw_dot_c, + gnatw_dot_f, + gnatw_dot_h, + gnatw_dot_i, + gnatw_dot_j, + gnatw_dot_k, + gnatw_dot_l, + gnatw_dot_m, + gnatw_dot_n, + gnatw_dot_o, + gnatw_dot_p, + gnatw_dot_q, + gnatw_dot_r, + gnatw_dot_s, + gnatw_dot_t, + gnatw_dot_u, + gnatw_dot_v, + gnatw_dot_w, + gnatw_dot_x, + gnatw_dot_y, + gnatw_dot_z, + gnatw_underscore_a, + gnatw_underscore_c, + gnatw_underscore_j, + gnatw_underscore_l, + gnatw_underscore_p, + gnatw_underscore_q, + gnatw_underscore_r, + gnatw_underscore_s, + gnaty, + gnatya, + gnatyb, + gnatyc, + gnatyd, + gnatye, + gnatyf, + gnatyh, + gnatyi, + gnatyk, + gnatyl, + gnatym, + gnatyn, + gnatyo, + gnatyp, + gnatyr, + gnatys, + gnatyu, + gnatyx, + gnatyz, + gnatyaa, + gnatybb, + gnatycc, + gnatydd, + gnatyii, + gnatyll, + gnatymm, + gnatyoo, + gnatyss, + gnatytt, + gnatel + ); + + subtype Active_Switch_Id is Switch_Id range gnatwb .. gnatel; + -- The range of switch ids that represent switches that trigger a specific + -- diagnostic check. + + type Switch_Type is record + + Status : Status_Type := Active; + -- The status will indicate whether the switch is currently active, + -- or has been deprecated. A deprecated switch will not control + -- diagnostics, and will not be emitted by the GNAT usage. + + Human_Id : String_Ptr := null; + -- The Human_Id will be a unique and stable string-based ID which + -- identifies the content of the switch within the switch registry. + -- This ID will appear in SARIF readers. + + Short_Name : String_Ptr := null; + -- The Short_Name will denote the -gnatXX name of the switch. + + Description : String_Ptr := null; + -- The description will contain the description of the switch, as it is + -- currently emitted by the GNAT usage. + + Documentation_Url : String_Ptr := null; + -- The documentation_url will point to the AdaCore documentation site + -- for the switch. + + end record; + + type Diagnostic_Kind is + (Error, + Warning, + Default_Warning, + -- Warning representing the old warnings created with the '??' insertion + -- character. These warning have the [enabled by default] tag. + Restriction_Warning, + -- Warning representing the old warnings created with the '?*?' + -- insertion character. These warning have the [restriction warning] + -- tag. + Style, + Tagless_Warning, + -- Warning representing the old warnings created with the '?' insertion + -- character. + Info, + Info_Warning + -- Info warnings are old messages where both warning and info were set + -- to true. These info messages behave like warnings and are usually + -- accompanied by a warning tag. + ); + + type Diagnostic_Entry_Type is record + Status : Status_Type := Active; + + Human_Id : String_Ptr := null; + -- A human readable code for the diagnostic. If the diagnostic has a + -- switch with a human id then the human_id of the switch shall be used + -- in SARIF reports. + + Documentation : String_Ptr := null; + + Switch : Switch_Id := No_Switch_Id; + -- The switch that controls the diagnostic message. + end record; + + type Diagnostic_Type is record + + Id : Diagnostic_Id := No_Diagnostic_Id; + + Kind : Diagnostic_Kind := Error; + + Switch : Switch_Id := No_Switch_Id; + + Message : String_Ptr := null; + + Warn_Err : Boolean := False; + -- Signal whether the diagnostic was converted from a warning to an + -- error. This needs to be set during the message emission as this + -- behavior depends on the context of the code. + + Serious : Boolean := True; + -- Typically all errors are considered serious and the compiler should + -- stop its processing since the tree is essentially invalid. However, + -- some errors are not serious and the compiler can continue its + -- processing to discover more critical errors. + + Locations : Labeled_Span_List := Labeled_Span_Lists.Nil; + + Sub_Diagnostics : Sub_Diagnostic_List := Sub_Diagnostic_Lists.Nil; + + Fixes : Fix_List := Fix_Lists.Nil; + end record; + + procedure Destroy (Elem : in out Diagnostic_Type); + pragma Inline (Destroy); + + package Diagnostics_Lists is new Doubly_Linked_Lists + (Element_Type => Diagnostic_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Diagnostic_List is Diagnostics_Lists.Doubly_Linked_List; + + All_Diagnostics : Diagnostic_List := Diagnostics_Lists.Create; + + procedure Add_Location + (Diagnostic : in out Diagnostic_Type; Location : Labeled_Span_Type); + + procedure Add_Sub_Diagnostic + (Diagnostic : in out Diagnostic_Type; + Sub_Diagnostic : Sub_Diagnostic_Type); + + procedure Add_Fix (Diagnostic : in out Diagnostic_Type; Fix : Fix_Type); + + procedure Record_Diagnostic (Diagnostic : Diagnostic_Type; + Update_Count : Boolean := True); + + procedure Print_Diagnostic (Diagnostic : Diagnostic_Type); + + function Primary_Location + (Diagnostic : Diagnostic_Type) return Labeled_Span_Type; + + type Labeled_Span_Array is + array (Positive range <>) of Labeled_Span_Type; + type Sub_Diagnostic_Array is + array (Positive range <>) of Sub_Diagnostic_Type; + type Fix_Array is + array (Positive range <>) of Fix_Type; + type Edit_Array is + array (Positive range <>) of Edit_Type; + + No_Locations : constant Labeled_Span_Array (1 .. 0) := (others => <>); + No_Sub_Diags : constant Sub_Diagnostic_Array (1 .. 0) := (others => <>); + No_Fixes : constant Fix_Array (1 .. 0) := (others => <>); + No_Edits : constant Edit_Array (1 .. 0) := (others => <>); + + function Make_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes) + return Diagnostic_Type; + + procedure Record_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes); + + function Labeled_Span (Span : Source_Span; + Label : String := ""; + Is_Primary : Boolean := True; + Is_Region : Boolean := False) + return Labeled_Span_Type; + + function Primary_Labeled_Span (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type; + + function Primary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type; + + function Secondary_Labeled_Span (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type; + + function Secondary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type; + + function Sub_Diag (Msg : String; + Kind : Sub_Diagnostic_Kind := + Diagnostics.Continuation; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Continuation (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Help (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Suggestion (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Fix (Description : String; + Edits : Edit_Array; + Applicability : Applicability_Type := Unspecified) + return Fix_Type; + + function Edit (Text : String; + Span : Source_Span) + return Edit_Type; +end Diagnostics; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index c8d87f0..f4660c4 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -33,6 +33,7 @@ with Atree; use Atree; with Casing; use Casing; with Csets; use Csets; with Debug; use Debug; +with Diagnostics.Converter; use Diagnostics.Converter; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -163,13 +164,6 @@ package body Errout is -- N_Defining_Program_Unit_Name, and N_Expanded_Name, the Prefix is -- included as well. - procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); - -- Add a sequence of characters to the current message. The characters may - -- be one of the special insertion characters (see documentation in spec). - -- Flag is the location at which the error is to be posted, which is used - -- to determine whether or not the # insertion needs a file name. The - -- variables Msg_Buffer are set on return Msglen. - procedure Set_Posted (N : Node_Id); -- Sets the Error_Posted flag on the given node, and all its parents that -- are subexpressions and then on the parent non-subexpression construct @@ -2563,6 +2557,10 @@ package body Errout is -- Local subprograms + procedure Emit_Error_Msgs; + -- Emit all error messages in the table use the pretty printed format if + -- -gnatdF is used otherwise use the brief format. + procedure Write_Error_Summary; -- Write error summary @@ -2602,6 +2600,108 @@ package body Errout is -- SGR_Span is the SGR string to start the section of code in the span, -- that should be closed with SGR_Reset. + -------------------- + -- Emit_Error_Msgs -- + --------------------- + + procedure Emit_Error_Msgs is + Use_Prefix : Boolean; + E : Error_Msg_Id; + begin + Set_Standard_Error; + + E := First_Error_Msg; + while E /= No_Error_Msg loop + + -- If -gnatdF is used, separate main messages from previous + -- messages with a newline (unless it is an info message) and + -- make continuation messages follow the main message with only + -- an indentation of two space characters, without repeating + -- file:line:col: prefix. + + Use_Prefix := + not (Debug_Flag_FF and then Errors.Table (E).Msg_Cont); + + if not Errors.Table (E).Deleted then + + if Debug_Flag_FF then + if Errors.Table (E).Msg_Cont then + Write_Str (" "); + elsif not Errors.Table (E).Info then + Write_Eol; + end if; + 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 + Write_Name (Reference_Name (Errors.Table (E).Sfile)); + end if; + + Write_Char (':'); + Write_Int (Int (Physical_To_Logical + (Errors.Table (E).Line, + Errors.Table (E).Sfile))); + Write_Char (':'); + + if Errors.Table (E).Col < 10 then + Write_Char ('0'); + end if; + + Write_Int (Int (Errors.Table (E).Col)); + Write_Str (": "); + + Write_Str (SGR_Reset); + end if; + + Output_Msg_Text (E); + Write_Eol; + + -- If -gnatdF is used, write the source code line + -- corresponding to the location of the main message (unless + -- it is an info message). Also write the source code line + -- corresponding to an insertion location inside + -- continuation messages. + + if Debug_Flag_FF + and then not Errors.Table (E).Info + then + if Errors.Table (E).Msg_Cont then + declare + Loc : constant Source_Ptr := + Errors.Table (E).Insertion_Sloc; + begin + if Loc /= No_Location then + Write_Source_Code_Lines + (To_Span (Loc), SGR_Span => SGR_Note); + end if; + end; + + else + 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).Optr, SGR_Span); + end; + end if; + end if; + end if; + + E := Errors.Table (E).Next; + end loop; + + Set_Standard_Output; + end Emit_Error_Msgs; + ------------------------- -- Write_Error_Summary -- ------------------------- @@ -3094,7 +3194,6 @@ package body Errout is E : Error_Msg_Id; Err_Flag : Boolean; - Use_Prefix : Boolean; -- Start of processing for Output_Messages @@ -3155,100 +3254,25 @@ package body Errout is Set_Standard_Output; - -- Brief Error mode - - elsif Brief_Output or (not Full_List and not Verbose_Mode) then - Set_Standard_Error; - - E := First_Error_Msg; - while E /= No_Error_Msg loop - - -- If -gnatdF is used, separate main messages from previous - -- messages with a newline (unless it is an info message) and - -- make continuation messages follow the main message with only - -- an indentation of two space characters, without repeating - -- file:line:col: prefix. - - Use_Prefix := - not (Debug_Flag_FF and then Errors.Table (E).Msg_Cont); - - if not Errors.Table (E).Deleted and then not Debug_Flag_KK then - - if Debug_Flag_FF then - if Errors.Table (E).Msg_Cont then - Write_Str (" "); - elsif not Errors.Table (E).Info then - Write_Eol; - end if; - 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 - Write_Name (Reference_Name (Errors.Table (E).Sfile)); - end if; - - Write_Char (':'); - Write_Int (Int (Physical_To_Logical - (Errors.Table (E).Line, - Errors.Table (E).Sfile))); - Write_Char (':'); - - if Errors.Table (E).Col < 10 then - Write_Char ('0'); - end if; - - Write_Int (Int (Errors.Table (E).Col)); - Write_Str (": "); + -- Do not print any messages if all messages are killed -gnatdK - Write_Str (SGR_Reset); - end if; + elsif Debug_Flag_KK then - Output_Msg_Text (E); - Write_Eol; + null; - -- If -gnatdF is used, write the source code line corresponding - -- to the location of the main message (unless it is an info - -- message). Also write the source code line corresponding to - -- an insertion location inside continuation messages. + -- Brief Error mode - if Debug_Flag_FF - and then not Errors.Table (E).Info - then - if Errors.Table (E).Msg_Cont then - declare - Loc : constant Source_Ptr := - Errors.Table (E).Insertion_Sloc; - begin - if Loc /= No_Location then - Write_Source_Code_Lines - (To_Span (Loc), SGR_Span => SGR_Note); - end if; - end; + elsif Brief_Output or (not Full_List and not Verbose_Mode) then - else - 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).Optr, SGR_Span); - end; - end if; - end if; - end if; + -- Use updated diagnostic mechanism - E := Errors.Table (E).Next; - end loop; + if Debug_Flag_Underscore_DD then + Convert_Errors_To_Diagnostics; - Set_Standard_Output; + Emit_Diagnostics; + else + Emit_Error_Msgs; + end if; end if; -- Full source listing case diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 2b0410a..fce7d9b502 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -292,31 +292,31 @@ package Errout is -- not necessary to go through any computational effort to include it. -- -- Note: this usage is obsolete; use ?? ?*? ?$? ?x? ?.x? ?_x? to - -- specify the string to be added when Warn_Doc_Switch is set to True. - -- If this switch is True, then for simple ? messages it has no effect. - -- This simple form is to ease transition and may be removed later - -- except for GNATprove-specific messages (info and warnings) which are - -- not subject to the same GNAT warning switches. + -- specify the string to be added when Warning_Doc_Switch is set to + -- True. If this switch is True, then for simple ? messages it has no + -- effect. This simple form is to ease transition and may be removed + -- later except for GNATprove-specific messages (info and warnings) + -- which are not subject to the same GNAT warning switches. -- Insertion character ?? (Two question marks: default warning) - -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ?, but if the flag Warning_Doc_Switch is True, adds the string -- "[enabled by default]" at the end of the warning message. For -- continuations, use this in each continuation message. -- Insertion character ?x? ?.x? ?_x? (warning with switch) -- "x" is a (lower-case) warning switch character. - -- Like ??, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ??, but if the flag Warning_Doc_Switch is True, adds the string -- "[-gnatwx]", "[-gnatw.x]", "[-gnatw_x]", or "[-gnatyx]" (for style -- messages), at the end of the warning message. For continuations, use -- this on each continuation message. -- Insertion character ?*? (restriction warning) - -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ?, but if the flag Warning_Doc_Switch is True, adds the string -- "[restriction warning]" at the end of the warning message. For -- continuations, use this on each continuation message. -- Insertion character ?$? (elaboration informational messages) - -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ?, but if the flag Warning_Doc_Switch is True, adds the string -- "[-gnatel]" at the end of the info message. This is used for the -- messages generated by the switch -gnatel. For continuations, use -- this on each continuation message. @@ -884,6 +884,13 @@ package Errout is -- ignored. A call with To=False restores the default treatment in which -- error calls are treated as usual (and as described in this spec). + procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); + -- Add a sequence of characters to the current message. The characters may + -- be one of the special insertion characters (see documentation in spec). + -- Flag is the location at which the error is to be posted, which is used + -- to determine whether or not the # insertion needs a file name. The + -- variables Msg_Buffer are set on return Msglen. + procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) renames Erroutc.Set_Warnings_Mode_Off; -- Called in response to a pragma Warnings (Off) to record the source diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index b284110..1174eb1 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -309,6 +309,16 @@ GNAT_ADA_OBJS = \ ada/cstand.o \ ada/debug.o \ ada/debug_a.o \ + ada/diagnostics-brief_emitter.o \ + ada/diagnostics-constructors.o \ + ada/diagnostics-converter.o \ + ada/diagnostics-json_utils.o \ + ada/diagnostics-pretty_emitter.o \ + ada/diagnostics-repository.o \ + ada/diagnostics-sarif_emitter.o \ + ada/diagnostics-switch_repository.o \ + ada/diagnostics-utils.o \ + ada/diagnostics.o \ ada/einfo-entities.o \ ada/einfo-utils.o \ ada/einfo.o \ @@ -594,6 +604,16 @@ GNATBIND_OBJS = \ ada/casing.o \ ada/csets.o \ ada/debug.o \ + ada/diagnostics-brief_emitter.o \ + ada/diagnostics-constructors.o \ + ada/diagnostics-converter.o \ + ada/diagnostics-json_utils.o \ + ada/diagnostics-pretty_emitter.o \ + ada/diagnostics-repository.o \ + ada/diagnostics-sarif_emitter.o \ + ada/diagnostics-switch_repository.o \ + ada/diagnostics-utils.o \ + ada/diagnostics.o \ ada/einfo-entities.o \ ada/einfo-utils.o \ ada/einfo.o \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 29db89c..12f9d65 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -334,6 +334,16 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \ switch.o switch-m.o table.o targparm.o tempdir.o types.o uintp.o \ uname.o urealp.o usage.o widechar.o warnsw.o \ seinfo.o einfo-entities.o einfo-utils.o sinfo-nodes.o sinfo-utils.o \ + diagnostics-brief_emitter.o \ + diagnostics-constructors.o \ + diagnostics-converter.o \ + diagnostics-json_utils.o \ + diagnostics-pretty_emitter.o \ + diagnostics-repository.o \ + diagnostics-sarif_emitter.o \ + diagnostics-switch_repository.o \ + diagnostics-utils.o \ + diagnostics.o \ $(EXTRA_GNATMAKE_OBJS) # Make arch match the current multilib so that the RTS selection code diff --git a/gcc/ada/libgnat/g-lists.adb b/gcc/ada/libgnat/g-lists.adb index cf118ab..5624df0 100644 --- a/gcc/ada/libgnat/g-lists.adb +++ b/gcc/ada/libgnat/g-lists.adb @@ -332,7 +332,7 @@ package body GNAT.Lists is -- The list has at least one outstanding iterator - if L.Iterators > 0 then + if Check_Tampering and then L.Iterators > 0 then raise Iterated; end if; end Ensure_Unlocked; diff --git a/gcc/ada/libgnat/g-lists.ads b/gcc/ada/libgnat/g-lists.ads index 4745913..1a3c18e 100644 --- a/gcc/ada/libgnat/g-lists.ads +++ b/gcc/ada/libgnat/g-lists.ads @@ -64,6 +64,8 @@ package GNAT.Lists is with procedure Destroy_Element (Elem : in out Element_Type); -- Element destructor + Check_Tampering : Boolean := True; + package Doubly_Linked_Lists is --------------------- diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index dd0c8b3..aea52f3 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1340,6 +1340,19 @@ package Opt is -- GNATMAKE, GNATLINK -- Set to False when no run_path_option should be issued to the linker + SARIF_File : Boolean := False; + -- GNAT + -- Output error and warning messages in SARIF format. Set to true when the + -- backend option "-fdiagnostics-format=sarif-file" is found on the + -- command line. The SARIF file is written to the file named: + -- <source_file>.gnat.sarif + + SARIF_Output : Boolean := False; + -- GNAT + -- Output error and warning messages in SARIF format. Set to true when the + -- backend option "-fdiagnostics-format=sarif-stderr" is found on the + -- command line. + Search_Directory_Present : Boolean := False; -- GNAT -- Set to True when argument is -I. Reset to False when next argument, a diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 0345f80..ec8acbb 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -28,6 +28,7 @@ with Stringt; use Stringt; with Uintp; use Uintp; with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; +with Diagnostics.Constructors; use Diagnostics.Constructors; separate (Par) package body Endh is @@ -896,6 +897,8 @@ package body Endh is procedure Output_End_Expected (Ins : Boolean) is End_Type : SS_End_Type; + Wrong_End_Start : Source_Ptr; + Wrong_End_Finish : Source_Ptr; begin -- Suppress message if this was a potentially junk entry (e.g. a record -- entry where no record keyword was present). @@ -932,8 +935,32 @@ package body Endh is elsif End_Type = E_Loop then if Error_Msg_Node_1 = Empty then - Error_Msg_SC -- CODEFIX - ("`END LOOP;` expected@ for LOOP#!"); + + if Debug_Flag_Underscore_DD then + + -- TODO: This is a quick hack to get the location of the + -- END LOOP for the demonstration. + + Wrong_End_Start := Token_Ptr; + + while Token /= Tok_Semicolon loop + Scan; -- past semicolon + end loop; + + Wrong_End_Finish := Token_Ptr; + + Restore_Scan_State (Scan_State); + + Record_End_Loop_Expected_Error + (End_Loc => To_Span (First => Wrong_End_Start, + Ptr => Wrong_End_Start, + Last => Wrong_End_Finish), + Start_Loc => Error_Msg_Sloc); + + else + Error_Msg_SC -- CODEFIX + ("`END LOOP;` expected@ for LOOP#!"); + end if; else Error_Msg_SC -- CODEFIX ("`END LOOP &;` expected@!"); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5cea155..ab8cc10 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -29,6 +29,7 @@ with Atree; use Atree; with Checks; use Checks; with Contracts; use Contracts; with Debug; use Debug; +with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -5757,13 +5758,18 @@ package body Sem_Ch13 is if not Check_Primitive_Function (Subp) then if Present (Ref_Node) then - Error_Msg_N ("improper function for default iterator!", - Ref_Node); - Error_Msg_Sloc := Sloc (Subp); - Error_Msg_NE - ("\\default iterator defined # " - & "must be a primitive function", - Ref_Node, Subp); + if Debug_Flag_Underscore_DD then + Record_Default_Iterator_Not_Primitive_Error + (Ref_Node, Subp); + else + Error_Msg_N ("improper function for default iterator!", + Ref_Node); + Error_Msg_Sloc := Sloc (Subp); + Error_Msg_NE + ("\\default iterator defined # " + & "must be a primitive function", + Ref_Node, Subp); + end if; end if; return False; @@ -15519,20 +15525,41 @@ package body Sem_Ch13 is -------------- procedure Too_Late is + S : Entity_Id; begin -- Other compilers seem more relaxed about rep items appearing too -- late. Since analysis tools typically don't care about rep items -- anyway, no reason to be too strict about this. if not Relaxed_RM_Semantics then - Error_Msg_N ("|representation item appears too late!", N); + if Debug_Flag_Underscore_DD then + + S := First_Subtype (T); + if Present (Freeze_Node (S)) then + Record_Representation_Too_Late_Error + (Rep => N, + Freeze => Freeze_Node (S), + Def => S); + else + Error_Msg_N ("|representation item appears too late!", N); + end if; + + else + Error_Msg_N ("|representation item appears too late!", N); + + S := First_Subtype (T); + if Present (Freeze_Node (S)) then + Error_Msg_NE + ("??no more representation items for }", + Freeze_Node (S), S); + end if; + end if; end if; end Too_Late; -- Local variables Parent_Type : Entity_Id; - S : Entity_Id; -- Start of processing for Rep_Item_Too_Late @@ -15566,14 +15593,6 @@ package body Sem_Ch13 is end if; Too_Late; - S := First_Subtype (T); - - if Present (Freeze_Node (S)) then - if not Relaxed_RM_Semantics then - Error_Msg_NE - ("??no more representation items for }", Freeze_Node (S), S); - end if; - end if; return True; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 9b77a81..9afaa89 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -27,6 +27,7 @@ with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Debug; use Debug; +with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -10861,40 +10862,86 @@ package body Sem_Ch4 is end loop; if No (Op_Id) then - Error_Msg_N ("invalid operand types for operator&", N); + if Debug_Flag_Underscore_DD then + if Nkind (N) /= N_Op_Concat then + if Nkind (N) in N_Op_Multiply | N_Op_Divide + and then Is_Fixed_Point_Type (Etype (L)) + and then Is_Integer_Type (Etype (R)) + then + Record_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op => N, + L => L, + L_Type => Etype (L), + R => R, + R_Type => Etype (R)); + + elsif Nkind (N) = N_Op_Multiply + and then Is_Fixed_Point_Type (Etype (R)) + and then Is_Integer_Type (Etype (L)) + then + Record_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op => N, + L => L, + L_Type => Etype (L), + R => R, + R_Type => Etype (R)); + else + Record_Invalid_Operand_Types_For_Operator_Error + (Op => N, + L => L, + L_Type => Etype (L), + R => R, + R_Type => Etype (R)); + end if; + elsif Is_Access_Type (Etype (L)) then + Record_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op => N, + L => L); + + elsif Is_Access_Type (Etype (R)) then + Record_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op => N, + R => R); + else + Record_Invalid_Operand_Types_For_Operator_General_Error + (N); + end if; + else + Error_Msg_N ("invalid operand types for operator&", N); - if Nkind (N) /= N_Op_Concat then - Error_Msg_NE ("\left operand has}!", N, Etype (L)); - Error_Msg_NE ("\right operand has}!", N, Etype (R)); + if Nkind (N) /= N_Op_Concat then + Error_Msg_NE ("\left operand has}!", N, Etype (L)); + Error_Msg_NE ("\right operand has}!", N, Etype (R)); - -- For multiplication and division operators with - -- a fixed-point operand and an integer operand, - -- indicate that the integer operand should be of - -- type Integer. + -- For multiplication and division operators with + -- a fixed-point operand and an integer operand, + -- indicate that the integer operand should be of + -- type Integer. - if Nkind (N) in N_Op_Multiply | N_Op_Divide - and then Is_Fixed_Point_Type (Etype (L)) - and then Is_Integer_Type (Etype (R)) - then - Error_Msg_N ("\convert right operand to `Integer`", N); + if Nkind (N) in N_Op_Multiply | N_Op_Divide + and then Is_Fixed_Point_Type (Etype (L)) + and then Is_Integer_Type (Etype (R)) + then + Error_Msg_N ("\convert right operand to `Integer`", N); - elsif Nkind (N) = N_Op_Multiply - and then Is_Fixed_Point_Type (Etype (R)) - and then Is_Integer_Type (Etype (L)) - then - Error_Msg_N ("\convert left operand to `Integer`", N); - end if; + elsif Nkind (N) = N_Op_Multiply + and then Is_Fixed_Point_Type (Etype (R)) + and then Is_Integer_Type (Etype (L)) + then + Error_Msg_N ("\convert left operand to `Integer`", N); + end if; - -- For concatenation operators it is more difficult to - -- determine which is the wrong operand. It is worth - -- flagging explicitly an access type, for those who - -- might think that a dereference happens here. + -- For concatenation operators it is more difficult to + -- determine which is the wrong operand. It is worth + -- flagging explicitly an access type, for those who + -- might think that a dereference happens here. - elsif Is_Access_Type (Etype (L)) then - Error_Msg_N ("\left operand is access type", N); + elsif Is_Access_Type (Etype (L)) then + Error_Msg_N ("\left operand is access type", N); - elsif Is_Access_Type (Etype (R)) then - Error_Msg_N ("\right operand is access type", N); + elsif Is_Access_Type (Etype (R)) then + Error_Msg_N ("\right operand is access type", N); + end if; end if; end if; end if; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index d52264a..b12db35 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -28,6 +28,8 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Contracts; use Contracts; +with Debug; use Debug; +with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -68,7 +70,6 @@ with Style; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; - package body Sem_Ch9 is ----------------------- @@ -2222,10 +2223,18 @@ package body Sem_Ch9 is -- Pragma case else - Error_Msg_Name_1 := Pragma_Name (Prio_Item); - Error_Msg_NE - ("pragma% for & has no effect when Lock_Free given??", - Prio_Item, Id); + if Debug_Flag_Underscore_DD then + Record_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node => Prio_Item, + Pragma_Name => Pragma_Name (Prio_Item), + Lock_Free_Node => Id, + Lock_Free_Range => Parent (Id)); + else + Error_Msg_Name_1 := Pragma_Name (Prio_Item); + Error_Msg_NE + ("pragma% for & has no effect when Lock_Free given??", + Prio_Item, Id); + end if; end if; end if; end; |