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.
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.
-- 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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
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;
-- 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
-- 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
-- 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 --
-------------------------
E : Error_Msg_Id;
Err_Flag : Boolean;
- Use_Prefix : Boolean;
-- Start of processing for Output_Messages
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
-- 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.
-- 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
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 \
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 \
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
-- 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;
with procedure Destroy_Element (Elem : in out Element_Type);
-- Element destructor
+ Check_Tampering : Boolean := True;
+
package Doubly_Linked_Lists 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
with Uintp; use Uintp;
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+with Diagnostics.Constructors; use Diagnostics.Constructors;
separate (Par)
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).
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@!");
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;
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;
--------------
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
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;
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;
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;
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;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-
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;
projects / thirdparty / gcc.git / commitdiff
