-- d_A Stop generation of ALI file
-- d_B Warn on build-in-place function calls
-- d_C
- -- d_D Use improved diagnostics
+ -- d_D
-- d_E Print diagnostics and switch repository
-- d_F Encode full invocation paths in ALI files
-- d_G
+++ /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-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Diagnostics.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-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with 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 local primitive or class-wide 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;
-
- ------------------------------------------
- -- Make_Mixed_Container_Aggregate_Error --
- ------------------------------------------
-
- function Make_Mixed_Container_Aggregate_Error
- (Aggr : Node_Id;
- Pos_Elem : Node_Id;
- Named_Elem : Node_Id) return Diagnostic_Type
- is
-
- begin
- return
- Make_Diagnostic
- (Msg =>
- "container aggregate cannot be both positional and named",
- Location => Primary_Labeled_Span (Aggr),
- Id => GNAT0011,
- Kind => Diagnostics.Error,
- Spans =>
- (1 => Secondary_Labeled_Span
- (Pos_Elem, "positional element "),
- 2 => Secondary_Labeled_Span
- (Named_Elem, "named element")));
- end Make_Mixed_Container_Aggregate_Error;
-
- --------------------------------------------
- -- Record_Mixed_Container_Aggregate_Error --
- --------------------------------------------
-
- procedure Record_Mixed_Container_Aggregate_Error
- (Aggr : Node_Id;
- Pos_Elem : Node_Id;
- Named_Elem : Node_Id)
- is
- begin
- Record_Diagnostic
- (Make_Mixed_Container_Aggregate_Error (Aggr, Pos_Elem, Named_Elem));
- end Record_Mixed_Container_Aggregate_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-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-with Namet; use Namet;
-
-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);
-
- function Make_Mixed_Container_Aggregate_Error
- (Aggr : Node_Id;
- Pos_Elem : Node_Id;
- Named_Elem : Node_Id) return Diagnostic_Type;
-
- procedure Record_Mixed_Container_Aggregate_Error
- (Aggr : Node_Id;
- Pos_Elem : Node_Id;
- Named_Elem : 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-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-with 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.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.
-
- function Get_Diagnostics_Kind (E_Msg : Error_Msg_Object)
- return Diagnostic_Kind
- is (if E_Msg.Kind = Erroutc.Warning then Get_Warning_Kind (E_Msg)
- elsif E_Msg.Kind = Erroutc.Style then Style
- elsif E_Msg.Kind = Erroutc.Info then Info
- elsif E_Msg.Kind = Erroutc.Non_Serious_Error then Non_Serious_Error
- else Error);
-
- -----------------------------------
- -- 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;
-
- Add_Location (D,
- Primary_Labeled_Span
- (if E_Msg.Insertion_Sloc /= No_Location
- then To_Span (E_Msg.Insertion_Sloc)
- else E_Msg.Sptr));
-
- if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then
- Add_Location (D, Secondary_Labeled_Span (E_Msg.Optr));
- 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;
-
- D.Kind := Get_Diagnostics_Kind (E_Msg);
-
- if E_Msg.Kind in Erroutc.Warning | Erroutc.Style | Erroutc.Info then
- D.Switch := Get_Switch_Id (E_Msg);
- end if;
-
- D.Warn_Err := E_Msg.Warn_Err;
-
- -- Convert the primary location
-
- Add_Location (D, Primary_Labeled_Span (E_Msg.Sptr));
-
- -- Convert the secondary location if it is different from the primary
-
- if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then
- Add_Location (D, Secondary_Labeled_Span (E_Msg.Optr));
- 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-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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 . 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-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-with 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-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Diagnostics.Repository; use Diagnostics.Repository;
-with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository;
-with Errout; use Errout;
-with Erroutc; use Erroutc;
-with Namet; use Namet;
-with Opt; use Opt;
-with Sinput; use Sinput;
-with Sinfo.Nodes; use Sinfo.Nodes;
-with Warnsw; use Warnsw;
-
-package body Diagnostics.Utils is
-
- ------------------
- -- Get_Human_Id --
- ------------------
-
- function Get_Human_Id (D : Diagnostic_Type) return String_Ptr is
- begin
- if D.Switch = No_Switch_Id then
- return Diagnostic_Entries (D.Id).Human_Id;
- else
- return Get_Switch (D).Human_Id;
- end if;
- end Get_Human_Id;
-
- ------------------
- -- To_File_Name --
- ------------------
-
- function To_File_Name (Sptr : Source_Ptr) return String is
- Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr);
- Ref_Name : constant File_Name_Type :=
- (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile)
- else Reference_Name (Sfile));
-
- begin
- return Get_Name_String (Ref_Name);
- end To_File_Name;
-
- --------------------
- -- Line_To_String --
- --------------------
-
- function Line_To_String (Sptr : Source_Ptr) return String is
- Line : constant Logical_Line_Number := Get_Logical_Line_Number (Sptr);
- Img_Raw : constant String := Int'Image (Int (Line));
-
- begin
- return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last);
- end Line_To_String;
-
- ----------------------
- -- Column_To_String --
- ----------------------
-
- function Column_To_String (Sptr : Source_Ptr) return String is
- Col : constant Column_Number := Get_Column_Number (Sptr);
- Img_Raw : constant String := Int'Image (Int (Col));
-
- begin
- return
- (if Col < 10 then "0" else "")
- & Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last);
- end Column_To_String;
-
- ---------------
- -- To_String --
- ---------------
-
- function To_String (Sptr : Source_Ptr) return String is
- begin
- return
- To_File_Name (Sptr) & ":" & Line_To_String (Sptr) & ":"
- & Column_To_String (Sptr);
- end To_String;
-
- --------------------
- -- Sloc_To_String --
- --------------------
-
- function Sloc_To_String
- (N : Node_Or_Entity_Id; Ref : Source_Ptr) return String
- is
-
- begin
- return Sloc_To_String (Sloc (N), Ref);
- end Sloc_To_String;
-
- --------------------
- -- Sloc_To_String --
- --------------------
-
- function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String
- is
-
- begin
- if Sptr = No_Location then
- return "at unknown location";
-
- elsif Sptr = System_Location then
- return "in package System";
-
- elsif Sptr = Standard_Location then
- return "in package Standard";
-
- elsif Sptr = Standard_ASCII_Location then
- return "in package Standard.ASCII";
-
- else
- if Full_File_Name (Get_Source_File_Index (Sptr))
- /= Full_File_Name (Get_Source_File_Index (Ref))
- then
- return "at " & To_String (Sptr);
- else
- return "at line " & Line_To_String (Sptr);
- end if;
- end if;
- end Sloc_To_String;
-
- ------------------
- -- To_Full_Span --
- ------------------
-
- function To_Full_Span (N : Node_Id) return Source_Span
- is
- Fst, Lst : Node_Id;
- begin
- First_And_Last_Nodes (N, Fst, Lst);
- return To_Span (Ptr => Sloc (N),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst));
- end To_Full_Span;
-
- ---------------
- -- To_String --
- ---------------
-
- function To_String (Id : Diagnostic_Id) return String is
- begin
- if Id = No_Diagnostic_Id then
- return "GNAT0000";
- else
- return Id'Img;
- end if;
- end To_String;
-
- -------------
- -- To_Name --
- -------------
-
- function To_Name (E : Entity_Id) return String is
- begin
- -- The name of the node operator "&" has many special cases. Reuse the
- -- node to name conversion implementation from the errout package for
- -- now.
-
- Error_Msg_Node_1 := E;
- Set_Msg_Text ("&", Sloc (E));
-
- return Msg_Buffer (1 .. Msglen);
- end To_Name;
-
- ------------------
- -- To_Type_Name --
- ------------------
-
- function To_Type_Name (E : Entity_Id) return String is
- begin
- Error_Msg_Node_1 := E;
- Set_Msg_Text ("}", Sloc (E));
-
- return Msg_Buffer (1 .. Msglen);
- end To_Type_Name;
-
- --------------------
- -- Kind_To_String --
- --------------------
-
- function Kind_To_String
- (D : Sub_Diagnostic_Type;
- Parent : Diagnostic_Type) return String
- is
- (case D.Kind is
- when Continuation => Kind_To_String (Parent),
- when Help => "help",
- when Note => "note",
- when Suggestion => "suggestion");
-
- --------------------
- -- Kind_To_String --
- --------------------
-
- function Kind_To_String (D : Diagnostic_Type) return String is
- (if D.Warn_Err then "error"
- else
- (case D.Kind is
- when Diagnostics.Error | Non_Serious_Error => "error",
- when Warning | Restriction_Warning | Default_Warning |
- Tagless_Warning => "warning",
- when Style => "style",
- when Info => "info"));
-
- ------------------------------
- -- Get_Primary_Labeled_Span --
- ------------------------------
-
- function Get_Primary_Labeled_Span (Spans : Labeled_Span_List)
- return Labeled_Span_Type
- is
- use Labeled_Span_Lists;
-
- S : Labeled_Span_Type;
- It : Iterator;
- begin
- if Present (Spans) then
- It := Iterate (Spans);
- while Has_Next (It) loop
- Next (It, S);
- if S.Is_Primary then
- return S;
- end if;
- end loop;
- end if;
-
- return No_Labeled_Span;
- end Get_Primary_Labeled_Span;
-
- --------------------
- -- Get_Doc_Switch --
- --------------------
-
- function Get_Doc_Switch (Diag : Diagnostic_Type) return String is
- begin
- if Warning_Doc_Switch
- and then Diag.Kind in Default_Warning
- | Info
- | Restriction_Warning
- | Style
- | Warning
- then
- if Diag.Switch = No_Switch_Id then
- if Diag.Kind = Restriction_Warning then
- return "[restriction warning]";
-
- -- Info messages can have a switch tag but they should not have
- -- a default switch tag.
-
- elsif Diag.Kind /= Info then
-
- -- For Default_Warning
-
- return "[enabled by default]";
- end if;
- else
- declare
- S : constant Switch_Type := Get_Switch (Diag);
- begin
- return "[-" & S.Short_Name.all & "]";
- end;
- end if;
- end if;
-
- return "";
- end Get_Doc_Switch;
-
- --------------------
- -- Appears_Before --
- --------------------
-
- function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean is
-
- begin
- return Appears_Before (Primary_Location (D1).Span.Ptr,
- Primary_Location (D2).Span.Ptr);
- end Appears_Before;
-
- --------------------
- -- Appears_Before --
- --------------------
-
- function Appears_Before (P1, P2 : Source_Ptr) return Boolean is
-
- begin
- if Get_Source_File_Index (P1) = Get_Source_File_Index (P2) then
- if Get_Logical_Line_Number (P1) = Get_Logical_Line_Number (P2) then
- return Get_Column_Number (P1) < Get_Column_Number (P2);
- else
- return Get_Logical_Line_Number (P1) < Get_Logical_Line_Number (P2);
- end if;
- else
- return Get_Source_File_Index (P1) < Get_Source_File_Index (P2);
- end if;
- end Appears_Before;
-
- ------------------------------
- -- Insert_Based_On_Location --
- ------------------------------
-
- procedure Insert_Based_On_Location
- (List : Diagnostic_List;
- Diagnostic : Diagnostic_Type)
- is
- use Diagnostics_Lists;
-
- It : Iterator := Iterate (List);
- D : Diagnostic_Type;
- begin
- -- This is the common scenario where the error is reported at the
- -- natural order the tree is processed. This saves a lot of time when
- -- looking for the correct position in the list when there are a lot of
- -- diagnostics.
-
- if Present (List) and then
- not Is_Empty (List) and then
- Appears_Before (Last (List), Diagnostic)
- then
- Append (List, Diagnostic);
- else
- while Has_Next (It) loop
- Next (It, D);
-
- if Appears_Before (Diagnostic, D) then
- Insert_Before (List, D, Diagnostic);
- return;
- end if;
- end loop;
-
- Append (List, Diagnostic);
- end if;
- end Insert_Based_On_Location;
-
-end Diagnostics.Utils;
+++ /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-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with 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
- begin
- return Get_Primary_Labeled_Span (Diagnostic.Locations);
- 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
- case Diagnostic.Kind is
- when Error =>
- Total_Errors_Detected := Total_Errors_Detected + 1;
- Serious_Errors_Detected := Serious_Errors_Detected + 1;
-
- when Non_Serious_Error =>
- Total_Errors_Detected := Total_Errors_Detected + 1;
-
- when Warning
- | Default_Warning
- | Tagless_Warning
- | Restriction_Warning
- | Style
- =>
- Warnings_Detected := Warnings_Detected + 1;
-
- if Diagnostic.Warn_Err then
- Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
- end if;
-
- when Info =>
- Info_Messages := Info_Messages + 1;
- end case;
- 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 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-2025, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with 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,
- GNAT0011);
-
- -- 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,
- Non_Serious_Error,
- -- 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.
- 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
- );
-
- 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.
-
- 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;
-- 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;
+with JSON_Utils; use JSON_Utils;
+with Output; use Output;
-package body Diagnostics.Repository is
+package body Errid is
+
+ ---------------
+ -- 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;
---------------------------------
-- Print_Diagnostic_Repository --
Write_Eol;
end Print_Diagnostic_Repository;
-end Diagnostics.Repository;
+end Errid;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
+-- Copyright (C) 19925, 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- --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-package Diagnostics.Repository is
+with Types; use Types;
+with Errsw; use Errsw;
+
+package Errid is
+
+ type Status_Type is
+ (Active,
+ Deprecated);
+
+ type Diagnostic_Id is
+ (No_Diagnostic_Id,
+ GNAT0001,
+ GNAT0002,
+ GNAT0003,
+ GNAT0004,
+ GNAT0005,
+ GNAT0006);
+
+ function To_String (Id : Diagnostic_Id) return String;
+ -- Convert the diagnostic ID to a 4 character string padded with 0-s.
+
+ 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 Diagnostics_Registry_Type is
array (Diagnostic_Id) of Diagnostic_Entry_Type;
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 =>
+ GNAT0003 =>
(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 =>
+ GNAT0004 =>
(Status => Active,
Human_Id => new String'("End_Loop_Expected_Error"),
Documentation => new String'("./error_codes/GNAT0009.md"),
Switch => No_Switch_Id),
- GNAT0010 =>
+ GNAT0005 =>
(Status => Active,
Human_Id => new String'("Representation_Too_Late_Error"),
Documentation => new String'("./error_codes/GNAT0010.md"),
Switch => No_Switch_Id),
- GNAT0011 =>
+ GNAT0006 =>
(Status => Active,
Human_Id => new String'("Mixed_Container_Aggregate_Error"),
Documentation => new String'("./error_codes/GNAT0011.md"),
procedure Print_Diagnostic_Repository;
-end Diagnostics.Repository;
+end Errid;
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;
with Erroutc; use Erroutc;
+with Erroutc.Pretty_Emitter;
+with Erroutc.SARIF_Emitter;
+with Errsw; use Errsw;
with Gnatvsn; use Gnatvsn;
with Lib; use Lib;
with Opt; use Opt;
with Nlists; use Nlists;
+with Osint; use Osint;
with Output; use Output;
with Scans; use Scans;
with Sem_Aux; use Sem_Aux;
-----------------------
procedure Error_Msg_Internal
- (Msg : String;
- Span : Source_Span;
- Opan : Source_Span;
- Msg_Cont : Boolean);
+ (Msg : String;
+ Span : Source_Span;
+ Opan : Source_Span;
+ Msg_Cont : Boolean;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes);
-- This is the low-level routine used to post messages after dealing with
-- the issue of messages placed on instantiations (which get broken up
-- into separate calls in Error_Msg). Span is the location on which the
end loop;
end Delete_Warning_And_Continuations;
+ ------------------
+ -- 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;
+ L.Next := No_Labeled_Span;
+
+ 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;
+
+ ----------
+ -- Edit --
+ ----------
+
+ function Edit (Text : String; Span : Source_Span) return Edit_Type is
+ begin
+ return (Text => new String'(Text), Span => Span, Next => No_Edit);
+ end Edit;
+
+ ---------
+ -- Fix --
+ ---------
+
+ function Fix (Description : String; Edits : Edit_Array) return Fix_Type is
+ First_Edit : Edit_Id := No_Edit;
+ Last_Edit : Edit_Id := No_Edit;
+ begin
+ for I in Edits'Range loop
+ Erroutc.Edits.Append (Edits (I));
+
+ if Last_Edit /= No_Edit then
+ Erroutc.Edits.Table (Last_Edit).Next := Erroutc.Edits.Last;
+ end if;
+ Last_Edit := Erroutc.Edits.Last;
+
+ -- Store the first element in the edit chain
+
+ if First_Edit = No_Edit then
+ First_Edit := Last_Edit;
+ end if;
+ end loop;
+
+ return (Description => new String'(Description),
+ Edits => First_Edit,
+ Next => No_Fix);
+ end Fix;
+
---------------
-- Error_Msg --
---------------
end Error_Msg;
procedure Error_Msg
- (Msg : String;
- Flag_Span : Source_Span;
- N : Node_Id)
+ (Msg : String;
+ Flag_Span : Source_Span;
+ N : Node_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes)
is
Flag_Location : constant Source_Ptr := Flag_Span.Ptr;
-- Error_Msg_Internal to place the message in the requested location.
if Instantiation (Sindex) = No_Location then
- Error_Msg_Internal (Msg, Flag_Span, Flag_Span, False);
+ Error_Msg_Internal
+ (Msg => Msg,
+ Span => Flag_Span,
+ Opan => Flag_Span,
+ Msg_Cont => False,
+ Error_Code => Error_Code,
+ Label => Label,
+ Spans => Spans,
+ Fixes => Fixes);
return;
end if;
-- Here we output the original message on the outer instantiation
Error_Msg_Internal
- (Msg => Msg,
- Span => To_Span (Actual_Error_Loc),
- Opan => Flag_Span,
- Msg_Cont => Msg_Cont_Status);
+ (Msg => Msg,
+ Span => To_Span (Actual_Error_Loc),
+ Opan => Flag_Span,
+ Msg_Cont => Msg_Cont_Status,
+ Error_Code => Error_Code,
+ Label => Label,
+ Spans => Spans,
+ Fixes => Fixes);
end;
end Error_Msg;
-- error flag in this situation.
S1 := Prev_Token_Ptr;
- C := Source (S1);
+ C := Sinput.Source (S1);
-- If the previous token is a string literal, we need a special approach
-- since there may be white space inside the literal and we don't want
loop
S1 := S1 + 1;
- if Source (S1) = C then
+ if Sinput.Source (S1) = C then
S1 := S1 + 1;
- exit when Source (S1) /= C;
- elsif Source (S1) in Line_Terminator then
+ exit when Sinput.Source (S1) /= C;
+ elsif Sinput.Source (S1) in Line_Terminator then
exit;
end if;
end loop;
-- characters in this context, since this is only for error recovery.
else
- while Source (S1) not in Line_Terminator
- and then Source (S1) /= ' '
- and then Source (S1) /= ASCII.HT
- and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-')
+ while Sinput.Source (S1) not in Line_Terminator
+ and then Sinput.Source (S1) /= ' '
+ and then Sinput.Source (S1) /= ASCII.HT
+ and then (Sinput.Source (S1) /= '-'
+ or else Sinput.Source (S1 + 1) /= '-')
and then S1 /= Token_Ptr
loop
S1 := S1 + 1;
-- we would really like to place it in the "last" character of the tab
-- space, but that it too much trouble to worry about).
- elsif Source (Token_Ptr - 1) = ' '
- or else Source (Token_Ptr - 1) = ASCII.HT
+ elsif Sinput.Source (Token_Ptr - 1) = ' '
+ or else Sinput.Source (Token_Ptr - 1) = ASCII.HT
then
Error_Msg (Msg, Token_Ptr - 1);
-----------------
procedure Error_Msg_F (Msg : String; N : Node_Id) is
- Fst, Lst : Node_Id;
begin
- First_And_Last_Nodes (N, Fst, Lst);
- Error_Msg_NEL (Msg, N, N,
- To_Span (Ptr => Sloc (Fst),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst)));
+ Error_Msg_NEL (Msg, N, N, To_Full_Span_First (N));
end Error_Msg_F;
------------------
N : Node_Id;
E : Node_Or_Entity_Id)
is
- Fst, Lst : Node_Id;
begin
- First_And_Last_Nodes (N, Fst, Lst);
- Error_Msg_NEL (Msg, N, E,
- To_Span (Ptr => Sloc (Fst),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst)));
+ Error_Msg_NEL (Msg, N, E, To_Full_Span_First (N));
end Error_Msg_FE;
------------------------------
------------------------
procedure Error_Msg_Internal
- (Msg : String;
- Span : Source_Span;
- Opan : Source_Span;
- Msg_Cont : Boolean)
+ (Msg : String;
+ Span : Source_Span;
+ Opan : Source_Span;
+ Msg_Cont : Boolean;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes)
is
Sptr : constant Source_Ptr := Span.Ptr;
Optr : constant Source_Ptr := Opan.Ptr;
Warn_Err : Boolean;
-- Set if warning to be treated as error
+ First_Fix : Fix_Id := No_Fix;
+ Last_Fix : Fix_Id := No_Fix;
+
+ Primary_Loc : Labeled_Span_Id := No_Labeled_Span;
+ Last_Loc : Labeled_Span_Id := No_Labeled_Span;
+
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
-- Remove (style) or info: at start of message
- if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then
- M := 9;
+ if Msglen > Style_Prefix'Length
+ and then Msg_Buffer (1 .. Style_Prefix'Length) = Style_Prefix
+ then
+ M := Style_Prefix'Length + 1;
- elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then
- M := 7;
+ elsif Msglen > Info_Prefix'Length
+ and then Msg_Buffer (1 .. Info_Prefix'Length) = Info_Prefix
+ then
+ M := Info_Prefix'Length + 1;
else
M := 1;
return;
end if;
+ if Continuation and then Has_Insertion_Line then
+ Erroutc.Locations.Append
+ (Primary_Labeled_Span (To_Span (Error_Msg_Sloc), Label));
+ else
+ Erroutc.Locations.Append (Primary_Labeled_Span (Span, Label));
+ end if;
+
+ Primary_Loc := Erroutc.Locations.Last;
+
+ Last_Loc := Primary_Loc;
+
+ for Span of Spans loop
+ Erroutc.Locations.Append (Span);
+ Erroutc.Locations.Table (Last_Loc).Next := Erroutc.Locations.Last;
+ Last_Loc := Erroutc.Locations.Last;
+ end loop;
+
+ for Fix of Fixes loop
+ Erroutc.Fixes.Append (Fix);
+ if Last_Fix /= No_Fix then
+ Erroutc.Fixes.Table (Last_Fix).Next := Erroutc.Fixes.Last;
+ end if;
+ Last_Fix := Erroutc.Fixes.Last;
+
+ -- Store the first element in the fix chain
+
+ if First_Fix = No_Fix then
+ First_Fix := Last_Fix;
+ end if;
+ end loop;
+
-- Here we build a new error object
Errors.Append
Uncond => Is_Unconditional_Msg,
Msg_Cont => Continuation,
Deleted => False,
- Kind => Error_Msg_Kind));
+ Kind => Error_Msg_Kind,
+ Locations => Primary_Loc,
+ Id => Error_Code,
+ Switch =>
+ Get_Switch_Id (Error_Msg_Kind, Warning_Msg_Char),
+ Fixes => First_Fix));
Cur_Msg := Errors.Last;
-- Test if warning to be treated as error
-- Error_Msg_N --
-----------------
- procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
- Fst, Lst : Node_Id;
+ procedure Error_Msg_N
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes)
+ is
begin
- First_And_Last_Nodes (N, Fst, Lst);
- Error_Msg_NEL (Msg, N, N,
- To_Span (Ptr => Sloc (N),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst)));
+ Error_Msg_NEL
+ (Msg => Msg,
+ N => N,
+ E => N,
+ Flag_Span => To_Full_Span (N),
+ Error_Code => Error_Code,
+ Label => Label,
+ Spans => Spans,
+ Fixes => Fixes);
end Error_Msg_N;
+ ----------------------
+ -- Error_Msg_N_Gigi --
+ ----------------------
+
+ procedure Error_Msg_N_Gigi (Msg : String; N : Node_Or_Entity_Id) is
+ begin
+ Error_Msg_N (Msg, N);
+ end Error_Msg_N_Gigi;
+
------------------
-- Error_Msg_NE --
------------------
procedure Error_Msg_NE
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes)
+ is
+ begin
+ Error_Msg_NEL
+ (Msg => Msg,
+ N => N,
+ E => E,
+ Flag_Span => To_Full_Span (N),
+ Error_Code => Error_Code,
+ Label => Label,
+ Spans => Spans,
+ Fixes => Fixes);
+ end Error_Msg_NE;
+
+ -----------------------
+ -- Error_Msg_NE_Gigi --
+ -----------------------
+
+ procedure Error_Msg_NE_Gigi
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id)
is
- Fst, Lst : Node_Id;
begin
- First_And_Last_Nodes (N, Fst, Lst);
- Error_Msg_NEL (Msg, N, E,
- To_Span (Ptr => Sloc (N),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst)));
- end Error_Msg_NE;
+ Error_Msg_NE (Msg, N, E);
+ end Error_Msg_NE_Gigi;
-------------------
-- Error_Msg_NEL --
end Error_Msg_NEL;
procedure Error_Msg_NEL
- (Msg : String;
- N : Node_Or_Entity_Id;
- E : Node_Or_Entity_Id;
- Flag_Span : Source_Span)
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id;
+ Flag_Span : Source_Span;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes)
is
begin
if Special_Msg_Delete (Msg, N, E) then
then
Debug_Output (N);
Error_Msg_Node_1 := E;
- Error_Msg (Msg, Flag_Span, N);
+ Error_Msg
+ (Msg => Msg,
+ Flag_Span => Flag_Span,
+ N => N,
+ Error_Code => Error_Code,
+ Label => Label,
+ Spans => Spans,
+ Fixes => Fixes);
else
Last_Killed := True;
Msg : String;
N : Node_Or_Entity_Id)
is
- Fst, Lst : Node_Id;
begin
if Eflag
and then In_Extended_Main_Source_Unit (N)
and then Comes_From_Source (N)
then
- First_And_Last_Nodes (N, Fst, Lst);
- Error_Msg_NEL (Msg, N, N,
- To_Span (Ptr => Sloc (N),
- First => First_Sloc (Fst),
- Last => Last_Sloc (Lst)));
+ Error_Msg_NEL (Msg, N, N, To_Full_Span (N));
end if;
end Error_Msg_NW;
Write_Str (",""option"":""" & Option & """");
end if;
- -- Print message content
+ -- Print message content and ensure that the removed style prefix is
+ -- still in the message.
Write_Str (",""message"":""");
+ if Errors.Table (E).Kind = Style then
+ Write_JSON_Escaped_String (Style_Prefix);
+ end if;
Write_JSON_Escaped_String (Errors.Table (E).Text);
Write_Str ("""");
procedure Write_Max_Errors;
-- Write message if max errors reached
- procedure Write_Source_Code_Lines
- (Span : Source_Span;
- SGR_Span : String);
- -- Write the source code line corresponding to Span, as follows when
- -- Span in on one line:
- --
- -- line | actual code line here with Span somewhere
- -- | ~~~~~^~~~
- --
- -- where the caret on the line points to location Span.Ptr, and the
- -- range Span.First..Span.Last is underlined.
- --
- -- or when the span is over multiple lines:
- --
- -- line | beginning of the Span on this line
- -- ... | ...
- -- line>| actual code line here with Span.Ptr somewhere
- -- ... | ...
- -- line | end of the Span on this line
- --
- -- or when the span is a simple location, as follows:
- --
- -- line | actual code line here with Span somewhere
- -- | ^ here
- --
- -- where the caret on the line points to location Span.Ptr
- --
- -- 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;
+ 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 Errors.Table (E).Kind /= Info then
- Write_Eol;
- end if;
- end if;
-
- if Use_Prefix then
- Output_Msg_Location (E);
- end if;
-
+ Output_Msg_Location (E);
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 Errors.Table (E).Kind /= 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).Kind = Info then SGR_Note
- elsif Errors.Table (E).Kind = Warning
- 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 if;
end Write_Max_Errors;
- -----------------------------
- -- Write_Source_Code_Lines --
- -----------------------------
-
- procedure Write_Source_Code_Lines
- (Span : Source_Span;
- SGR_Span : String)
- is
- 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 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;
- Mark : Boolean;
- Width : Positive);
- -- Output the line number Num over Width characters, with possibly
- -- a Mark to denote the line with the main location when reporting
- -- a span over multiple lines.
-
- ------------------
- -- 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;
-
- -----------
- -- 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;
-
- ------------------
- -- 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;
- Mark : Boolean;
- Width : Positive)
- is
- begin
- Write_Str (Image (Positive (Num), Width => Width));
- Write_Str ((if Mark then ">" else " ") & "|");
- end Write_Line_Marker;
-
- -- Local variables
-
- Loc : constant Source_Ptr := Span.Ptr;
- Line : constant Pos := Pos (Get_Physical_Line_Number (Loc));
-
- Col : constant Natural := Natural (Get_Column_Number (Loc));
-
- Fst : constant Source_Ptr := Span.First;
- Line_Fst : constant Pos :=
- Pos (Get_Physical_Line_Number (Fst));
- Col_Fst : constant Natural :=
- Natural (Get_Column_Number (Fst));
- Lst : constant Source_Ptr := Span.Last;
- Line_Lst : constant Pos :=
- Pos (Get_Physical_Line_Number (Lst));
- Col_Lst : constant Natural :=
- Natural (Get_Column_Number (Lst));
-
- Width : constant := 5;
- Buf : Source_Buffer_Ptr;
- Cur_Loc : Source_Ptr := Fst;
- Cur_Line : Pos := Line_Fst;
-
- -- Start of processing for Write_Source_Code_Lines
-
- begin
- if Loc >= First_Source_Ptr then
- Buf := Source_Text (Get_Source_File_Index (Loc));
-
- -- First line of the span with actual source code. We retrieve
- -- the beginning of the line instead of relying on Col_Fst, as
- -- ASCII.HT characters change column numbers by possibly more
- -- than one.
-
- Write_Line_Marker
- (Cur_Line,
- Line_Fst /= Line_Lst and then Cur_Line = Line,
- Width);
- Write_Buffer (Buf, Get_Line_Start (Buf, Cur_Loc), Cur_Loc - 1);
-
- -- Output the first/caret/last lines of the span, as well as
- -- lines that are directly above/below the caret if they complete
- -- the gap with first/last lines, otherwise use ... to denote
- -- intermediate lines.
-
- -- If the span is on one line and not a simple source location,
- -- color it appropriately.
-
- if Line_Fst = Line_Lst
- and then Col_Fst /= Col_Lst
- then
- Write_Str (SGR_Span);
- end if;
-
- declare
- function Do_Write_Line (Cur_Line : Pos) return Boolean is
- (Cur_Line in Line_Fst | Line | Line_Lst
- or else
- (Cur_Line = Line_Fst + 1 and then Cur_Line = Line - 1)
- or else
- (Cur_Line = Line + 1 and then Cur_Line = Line_Lst - 1));
- begin
- while Cur_Loc <= Buf'Last
- and then Cur_Loc <= Lst
- loop
- if Do_Write_Line (Cur_Line) then
- Write_Buffer_Char (Buf, Cur_Loc);
- end if;
-
- if Buf (Cur_Loc) = ASCII.LF then
- Cur_Line := Cur_Line + 1;
-
- -- Output ... for skipped lines
-
- if (Cur_Line = Line
- and then not Do_Write_Line (Cur_Line - 1))
- or else
- (Cur_Line = Line + 1
- and then not Do_Write_Line (Cur_Line))
- then
- Write_Str ((1 .. Width - 3 => ' ') & "... | ...");
- Write_Eol;
- end if;
-
- -- Display the line marker if the line should be
- -- displayed.
-
- if Do_Write_Line (Cur_Line) then
- Write_Line_Marker
- (Cur_Line,
- Line_Fst /= Line_Lst and then Cur_Line = Line,
- Width);
- end if;
- end if;
-
- Cur_Loc := Cur_Loc + 1;
- end loop;
- end;
-
- if Line_Fst = Line_Lst
- and then Col_Fst /= Col_Lst
- then
- Write_Str (SGR_Reset);
- end if;
-
- -- Output the rest of the last line of the span
-
- Write_Buffer (Buf, Cur_Loc, Get_Line_End (Buf, Cur_Loc));
-
- -- If the span is on one line, output a second line with caret
- -- sign pointing to location Loc
-
- if Line_Fst = Line_Lst then
- Write_Str (String'(1 .. Width => ' '));
- Write_Str (" |");
- Write_Str (String'(1 .. Col_Fst - 1 => ' '));
-
- Write_Str (SGR_Span);
-
- Write_Str (String'(Col_Fst .. Col - 1 => '~'));
- Write_Str ("^");
- Write_Str (String'(Col + 1 .. Col_Lst => '~'));
-
- -- If the span is really just a location, add the word "here"
- -- to clarify this is the location for the message.
-
- if Col_Fst = Col_Lst then
- Write_Str (" here");
- end if;
-
- Write_Str (SGR_Reset);
-
- Write_Eol;
- end if;
- end if;
- end Write_Source_Code_Lines;
-
-- Local variables
E : Error_Msg_Id;
Err_Flag : Boolean;
+ 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;
+
-- Start of processing for Output_Messages
begin
-- Use updated diagnostic mechanism
- if Debug_Flag_Underscore_DD then
- Convert_Errors_To_Diagnostics;
+ if Opt.SARIF_Output then
+ Set_Standard_Error;
+ Erroutc.SARIF_Emitter.Print_SARIF_Report;
+ Set_Standard_Output;
+
+ elsif Opt.SARIF_File then
+ System.OS_Lib.Delete_File (Sarif_File_Name, Dummy);
+ declare
+ Output_FD :
+ constant System.OS_Lib.File_Descriptor :=
+ System.OS_Lib.Create_New_File
+ (Sarif_File_Name, Fmode => System.OS_Lib.Text);
- Emit_Diagnostics;
+ begin
+ Set_Output (Output_FD);
+ Erroutc.SARIF_Emitter.Print_SARIF_Report;
+ Set_Standard_Output;
+ System.OS_Lib.Close (Output_FD);
+ end;
+ elsif Debug_Flag_FF then
+ Erroutc.Pretty_Emitter.Print_Error_Messages;
else
Emit_Error_Msgs;
end if;
end if;
+ if Debug_Flag_Underscore_EE then
+ -- Print the switch repository to a file
+
+ System.OS_Lib.Delete_File (Switches_File_Name, Dummy);
+ declare
+ Output_FD : constant System.OS_Lib.File_Descriptor :=
+ System.OS_Lib.Create_New_File
+ (Switches_File_Name,
+ Fmode => System.OS_Lib.Text);
+
+ begin
+ Set_Output (Output_FD);
+
+ Print_Switch_Repository;
+
+ Set_Standard_Output;
+
+ System.OS_Lib.Close (Output_FD);
+ end;
+
+ -- Print the diagnostics repository to a file
+
+ System.OS_Lib.Delete_File (Diagnostics_File_Name, Dummy);
+ declare
+ Output_FD : constant System.OS_Lib.File_Descriptor :=
+ System.OS_Lib.Create_New_File
+ (Diagnostics_File_Name,
+ Fmode => System.OS_Lib.Text);
+
+ begin
+ Set_Output (Output_FD);
+
+ Print_Diagnostic_Repository;
+
+ Set_Standard_Output;
+
+ System.OS_Lib.Close (Output_FD);
+ end;
+ end if;
+
-- Full source listing case
if Full_List then
Msglen := 0;
Flag_Source := Get_Source_File_Index (Flag);
- -- Skip info: at start, we have recorded this in Error_Msg_Kind, and
- -- this will be used (Info field in error message object) to put back
- -- the string when it is printed. We need to do this, or we get confused
+ P := Text'First;
+
+ -- Skip the continuation symbols at the start
+
+ if P <= Text'Last and then Text (P) = '\' then
+ Continuation := True;
+ P := P + 1;
+
+ if P <= Text'Last and then Text (P) = '\' then
+ Continuation_New_Line := True;
+ P := P + 1;
+ end if;
+ end if;
+
+ -- Skip the message kind tokens at start since it is recorded
+ -- in Error_Msg_Kind, and this will be used to put back the string when
+ -- it is printed. We need to do this, or we get confused
-- with instantiation continuations.
- if Text'Length > 6
- and then Text (Text'First .. Text'First + 5) = "info: "
+ if Text'Length > P + Info_Prefix'Length - 1
+ and then Text (P .. P + Info_Prefix'Length - 1) = Info_Prefix
then
- P := Text'First + 6;
- else
- P := Text'First;
+ P := P + Info_Prefix'Length;
+ elsif Text'Length > P + Style_Prefix'Length - 1
+ and then Text (P .. P + Style_Prefix'Length - 1) = Style_Prefix
+ then
+ P := P + Style_Prefix'Length;
+ elsif Text'Length > P + High_Prefix'Length - 1
+ and then Text (P .. P + High_Prefix'Length - 1) = High_Prefix
+ then
+ P := P + High_Prefix'Length;
+ elsif Text'Length > P + Medium_Prefix'Length - 1
+ and then Text (P .. P + Medium_Prefix'Length - 1) = Medium_Prefix
+ then
+ P := P + Medium_Prefix'Length;
+ elsif Text'Length > P + Low_Prefix'Length - 1
+ and then Text (P .. P + Low_Prefix'Length - 1) = Low_Prefix
+ then
+ P := P + Low_Prefix'Length;
end if;
-- Loop through characters of message
when '#' =>
Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
- when '\' =>
- Continuation := True;
-
- if P <= Text'Last and then Text (P) = '\' then
- Continuation_New_Line := True;
- P := P + 1;
- end if;
-
when '@' =>
Set_Msg_Insertion_Column;
end if;
end SPARK_Msg_NE;
+ ------------------
+ -- 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_Full_Span_First --
+ ------------------------
+
+ function To_Full_Span_First (N : Node_Id) return Source_Span is
+ Fst, Lst : Node_Id;
+ begin
+ First_And_Last_Nodes (N, Fst, Lst);
+ return To_Span (Ptr => Sloc (Fst),
+ First => First_Sloc (Fst),
+ Last => Last_Sloc (Lst));
+ end To_Full_Span_First;
+
+ -------------
+ -- 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;
+
--------------------------
-- Unwind_Internal_Type --
--------------------------
with Err_Vars;
with Erroutc;
+with Errid; use Errid;
with Namet; use Namet;
with Table;
with Types; use Types;
-- client to set this to No_Error_Msg and then test it to see if a warning
-- message has been issued.
+ subtype Labeled_Span_Type is Erroutc.Labeled_Span_Type;
+ subtype Fix_Type is Erroutc.Fix_Type;
+ subtype Edit_Type is Erroutc.Edit_Type;
+
+ type Labeled_Span_Array is
+ array (Positive range <>) of Labeled_Span_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_Fixes : constant Fix_Array (1 .. 0) := (others => <>);
+ No_Edits : constant Edit_Array (1 .. 0) := (others => <>);
+
procedure Delete_Warning_And_Continuations (Msg : Error_Msg_Id);
-- Deletes the given warning message and all its continuations. This is
-- typically used in conjunction with reading the value of Warning_Msg.
procedure Error_Msg
(Msg : String; Flag_Location : Source_Ptr; N : Node_Id);
procedure Error_Msg
- (Msg : String; Flag_Span : Source_Span; N : Node_Id);
+ (Msg : String;
+ Flag_Span : Source_Span;
+ N : Node_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes);
-- Output a message at specified location. Can be called from the parser
-- or the semantic analyzer. If N is set, points to the relevant node for
-- this message. The version with a span is preferred whenever possible,
-- in other cases the version with a location can still be used.
+ --
+ -- @param Error_Code is the unique identifier for that kind of message.
+ -- @param Label specifies an optional short label that will be displayed
+ -- under the Flag_Span.
+ -- @param Spans specifies other spans with labels that will be highlighted
+ -- in the error message.
+ -- @param Fixes contains a list of possible fixes for the error message.
procedure Error_Msg
(Msg : String;
-- Output a message at the start of the previous token. This routine can
-- be called only from the parser, since it references Prev_Token_Ptr.
- procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id);
+ procedure Error_Msg_N
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes);
-- Output a message at the Sloc of the given node. This routine can be
-- called from the parser or the semantic analyzer, although the call from
-- the latter is much more common (and is the most usual way of generating
-- suppressed if the node N already has a message posted, or if it is a
-- warning and N is an entity node for which warnings are suppressed.
+ procedure Error_Msg_N_Gigi (Msg : String; N : Node_Or_Entity_Id);
+ -- This is a wrapper for the Error_Msg_N method that gets linked to gigi.
+ --
-- WARNING: There is a matching C declaration of this subprogram in fe.h
procedure Error_Msg_F (Msg : String; N : Node_Id);
-- want for placing an error message flag in the right place.
procedure Error_Msg_NE
- (Msg : String;
- N : Node_Or_Entity_Id;
- E : Node_Or_Entity_Id);
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes);
-- Output a message at the Sloc of the given node N, with an insertion of
-- the name from the given entity node E. This is used by the semantic
-- routines, where this is a common error message situation. The Msg text
-- will contain a & or } as usual to mark the insertion point. This
-- routine can be called from the parser or the analyzer.
+ procedure Error_Msg_NE_Gigi
+ (Msg : String; N : Node_Or_Entity_Id; E : Node_Or_Entity_Id);
+ -- This is a wrapper for the Error_Msg_NE method that gets linked to gigi.
+ --
-- WARNING: There is a matching C declaration of this subprogram in fe.h
procedure Error_Msg_FE
E : Node_Or_Entity_Id;
Flag_Location : Source_Ptr);
procedure Error_Msg_NEL
- (Msg : String;
- N : Node_Or_Entity_Id;
- E : Node_Or_Entity_Id;
- Flag_Span : Source_Span);
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id;
+ Flag_Span : Source_Span;
+ Error_Code : Diagnostic_Id := No_Diagnostic_Id;
+ Label : String := "";
+ Spans : Labeled_Span_Array := No_Locations;
+ Fixes : Fix_Array := No_Fixes);
-- Exactly the same as Error_Msg_NE, except that the flag is placed at
-- the specified Flag_Location/Flag_Span instead of at Sloc (N).
-- at the original source tree, since that's what we want for placing an
-- error message flag in the right place.
+ function To_Full_Span (N : Node_Id) return Source_Span;
+ -- Creates a Source_Span by calculating the positions of its first and last
+ -- node contained by N in the source code and sets the span to point at the
+ -- location of N.
+
+ function To_Full_Span_First (N : Node_Id) return Source_Span;
+ -- Creates a Source_Span by calculating the positions of its first and last
+ -- node contained by N in the source code and sets the span to point to the
+ -- starting position of the span.
+
function First_Node (C : Node_Id) return Node_Id;
-- Return the first output of First_And_Last_Nodes
procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg;
-- Debugging routine to dump an error message
+ function Labeled_Span
+ (Span : Source_Span;
+ Label : String := "";
+ Is_Primary : Boolean := True;
+ Is_Region : Boolean := False)
+ return Labeled_Span_Type;
+ -- Constructs a Labeled_Span structure with all of its attributes.
+
+ 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;
+ -- Shorthand function for creating Primary Labeled_Spans
+
+ 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;
+ -- Shorthand function for creating Secondary Labeled_Spans
+
+ function Edit (Text : String; Span : Source_Span) return Edit_Type;
+ -- Constructs a Edit structure with all of its attributes.
+
+ function Fix (Description : String; Edits : Edit_Array) return Fix_Type;
+ -- Constructs a Fix structure with all of its attributes.
+
------------------------------------
-- SPARK Error Output Subprograms --
------------------------------------
-- Function Is_Size_Too_Small_Message tests for it by testing a prefix.
-- The function and constant should be kept in synch.
+ function To_Name (E : Entity_Id) return String;
+ -- Converts an entities name into a String as if the '&' insertion
+ -- character was used.
+
end Errout;
-- --
------------------------------------------------------------------------------
-with Diagnostics.Utils; use Diagnostics.Utils;
-with Output; use Output;
-with Sinput; use Sinput;
-with Erroutc; use Erroutc;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Sinput; use Sinput;
+with GNAT.Lists; use GNAT.Lists;
-package body Diagnostics.Pretty_Emitter is
+package body Erroutc.Pretty_Emitter is
REGION_OFFSET : constant := 1;
-- Number of characters between the line bar and the region span
MAX_BAR_POS : constant := 7;
-- The maximum position of the line bar from the start of the line
+
+ procedure Destroy (Elem : in out Labeled_Span_Type);
+ pragma Inline (Destroy);
+
+ procedure Destroy (Elem : in out Labeled_Span_Type) is
+ begin
+ -- Diagnostic elements will be freed when all the diagnostics have been
+ -- emitted.
+ null;
+ end Destroy;
+
+ package Labeled_Span_Lists is new Doubly_Linked_Lists
+ (Element_Type => Labeled_Span_Type,
+ "=" => "=",
+ Destroy_Element => Destroy,
+ Check_Tampering => False);
+ subtype Labeled_Span_List is Labeled_Span_Lists.Doubly_Linked_List;
+
type Printable_Line is record
- First : Source_Ptr;
+ First : Source_Ptr;
-- The first character of the line
- Last : Source_Ptr;
+ Last : Source_Ptr;
-- The last character of the line
Line_Nr : Pos;
-- The line number
- Spans : Labeled_Span_List;
+ Spans : Labeled_Span_List;
-- The spans applied on the line
end record;
subtype Lines_List is Lines_Lists.Doubly_Linked_List;
type File_Sections is record
- File : String_Ptr;
+ File : String_Ptr;
-- Name of the file
+ Ptr : Source_Ptr;
+ -- Pointer to the Primary location in the file section that is printed
+ -- at the start of the file section. If there are none then the first
+ -- location in the section.
+
Lines : Lines_List;
-- Lines to be printed for the file
end record;
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);
+ (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,
subtype File_Section_List is File_Section_Lists.Doubly_Linked_List;
- function Create_File_Sections (Spans : Labeled_Span_List)
- return File_Section_List;
+ function Create_File_Sections
+ (Locations : Labeled_Span_Id) return File_Section_List;
-- Create a list of file sections from the labeled spans that are to be
-- printed.
--
-- 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);
+ (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);
+ (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);
+ (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 Get_Region_Span
+ (Spans : Labeled_Span_List) return Labeled_Span_Type;
function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean;
- procedure Write_Region_Delimiter;
+ procedure Write_Region_Delimiter (SGR_Code : String);
-- Write the arms signifying the start and end of a region span
-- e.g. +--
- procedure Write_Region_Bar;
+ procedure Write_Region_Bar (SGR_Code : String);
-- Write the bar signifying the continuation of a region span
-- e.g. |
- procedure Write_Region_Continuation;
+ procedure Write_Region_Continuation (SGR_Code : String);
-- Write the continuation signifying the continuation of a region span
-- e.g. :
-- 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);
+ -- Removes the leading whitespace from the 'Image of a Natural number.
+
+ procedure Write_Span_Labels
+ (Loc : Labeled_Span_Type;
+ L : Printable_Line;
+ Line_Size : Integer;
+ Idx : String;
+ Within_Region_Span : Boolean;
+ SGR_Code : String;
+ Region_Span_SGR_Code : String);
+
+ procedure Write_File_Section
+ (Sec : File_Sections;
+ Write_File_Name : Boolean;
+ File_Name_Offset : Integer;
+ Include_Spans : Boolean;
+ SGR_Code : String := SGR_Note);
+ -- Prints the labled spans for a given File_Section.
+ --
+ -- --> <File_Section.File_Name>
+ -- <Labeled_Spans inside the file>
+
+ procedure Write_Labeled_Spans
+ (Locations : Labeled_Span_Id;
+ Write_File_Name : Boolean;
+ File_Name_Offset : Integer;
+ Include_Spans : Boolean := True;
+ SGR_Code : String := SGR_Note);
+ -- Pretty-prints all of the code regions indicated by the Locations. The
+ -- labeled spans in the Locations are grouped by file into File_Sections
+ -- and sorted by the file name of the Primary location followed by all
+ -- other locations sorted alphabetically.
procedure Write_Intersecting_Labels
- (Intersecting_Labels : Labeled_Span_List);
+ (Intersecting_Labels : Labeled_Span_List; SGR_Code : String);
+ -- Prints the indices and their associated labels of intersecting labels.
+ --
+ -- Labeled spans that are insercting on the same line are printed without
+ -- labels. Instead the span pointer is replaced by an index number and in
+ -- the end all of the indices are printed with their associated labels.
+ --
+ --
+ -- 42 | [for I in V1.First_Index .. V1.Last_Index => V1(I), -6];
+ -- | ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- | 1-
+ -- | 2-------------------------------------------
+ -- | 1: positional element
+ -- | 2: named element
function Get_Line_End
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr) return Source_Ptr;
+ (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr;
-- Get the source location for the end of the line (LF) in Buf for Loc. If
-- Loc is past the end of Buf already, return Buf'Last.
function Get_Line_Start
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr) return Source_Ptr;
+ (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
-- Width digits.
procedure Write_Buffer
- (Buf : Source_Buffer_Ptr;
- First : Source_Ptr;
- Last : Source_Ptr);
+ (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);
+ 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_Line_Marker (Num : Pos; Width : Positive);
+ -- Attempts to write the line number within Width number of whitespaces
+ -- followed by a bar ':' symbol.
+ --
+ -- e.g ' 12 |'
+ --
+ -- This is usually used on source code lines that are marked by a span.
procedure Write_Empty_Bar_Line (Width : Integer);
+ -- Writes Width number of whitespaces and a bar '|' symbol.
+ --
+ -- e.g ' |'
+ --
+ -- This is usually used on lines where the label is going to printed.
procedure Write_Empty_Skip_Line (Width : Integer);
+ -- Writes Width number of whitespaces and a bar ':' symbol.
+ --
+ -- e.g ' :'
+ --
+ -- This is usually used between non-continous source lines that neec to be
+ -- printed.
- procedure Write_Error_Msg_Line (Diag : Diagnostic_Type);
+ procedure Write_Error_Msg_Line (E_Msg : Error_Msg_Object);
-- 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;
+ function Should_Write_File_Name
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean;
-- If the sub-diagnostic and the main diagnostic only point to the same
-- file then there is no reason to add the file name to the sub-diagnostic.
- function Should_Write_Spans (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type)
- return Boolean;
+ function Should_Write_Spans
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean;
-- Old sub-diagnostics used to have the same location as the main
-- diagnostic in order to group them correctly. However in most cases
-- it was not meant to point to a location but rather add an additional
-- 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_Diagnostic (E : Error_Msg_Id);
+ -- Entry point for printing a primary diagnostic message.
- procedure Print_Fix
- (Fix : Fix_Type;
- Offset : Integer);
+ procedure Print_Edit (Edit : Edit_Type; Offset : Integer);
+ -- Prints an edit object as follows:
+ --
+ -- --> <File_Name>
+ -- -<Line_Nr> <Old_Line>
+ -- +<Line_Nr> <New_Line>
+
+ procedure Print_Fix (Fix : Fix_Type; Offset : Integer);
+ -- Prints a fix object as follows
+ --
+ -- + Fix: <Fix.Description>
+ -- <Fix.Edits>
procedure Print_Sub_Diagnostic
- (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type;
- Offset : Integer);
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object; Offset : Integer);
+
+ function To_String (Sptr : Source_Ptr) return String;
+ -- Convert the source pointer to a string of the form: "file:line:column"
+
+ function To_File_Name (Sptr : Source_Ptr) return String;
+ -- Converts the file name of the Sptr to a string.
+
+ function Line_To_String (Sptr : Source_Ptr) return String;
+ -- Converts the logical line number of the Sptr to a string.
+
+ function Column_To_String (Sptr : Source_Ptr) return String;
+ -- Converts the column number of the Sptr to a string. Column values less
+ -- than 10 are prefixed with a 0.
-------------
-- Destroy --
-------------
- procedure Destroy (Elem : in out Printable_Line)
- is
+ procedure Destroy (Elem : in out Printable_Line) is
begin
- -- Diagnostic elements will be freed when all the diagnostics have been
- -- emitted.
- null;
+ Labeled_Span_Lists.Destroy (Elem.Spans);
end Destroy;
-------------
-- Destroy --
-------------
- procedure Destroy (Elem : in out File_Sections)
- is
+ procedure Destroy (Elem : in out File_Sections) is
begin
Free (Elem.File);
+ Lines_Lists.Destroy (Elem.Lines);
end Destroy;
------------------
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
+ while Cur_Loc < Buf'Last and then Buf (Cur_Loc) /= ASCII.LF loop
Cur_Loc := Cur_Loc + 1;
end loop;
is
Cur_Loc : Source_Ptr := Loc;
begin
- while Cur_Loc > Buf'First
- and then Buf (Cur_Loc - 1) /= ASCII.LF
- loop
+ while Cur_Loc > Buf'First and then Buf (Cur_Loc - 1) /= ASCII.LF loop
Cur_Loc := Cur_Loc - 1;
end loop;
is
Cur_Loc : Source_Ptr := Get_Line_Start (Buf, Loc);
begin
- while Cur_Loc < Buf'Last
- and then Buf (Cur_Loc) = ' '
- loop
+ while Cur_Loc < Buf'Last and then Buf (Cur_Loc) = ' ' loop
Cur_Loc := Cur_Loc + 1;
end loop;
for J in reverse 1 .. Width loop
if Curr > 0 then
Str (J) := Character'Val (Character'Pos ('0') + Curr mod 10);
- Curr := Curr / 10;
+ Curr := Curr / 10;
else
Str (J) := ' ';
end if;
-- Has_Multiple_Labeled_Spans --
--------------------------------
- function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean
- is
+ function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean is
Count : Natural := 0;
- Loc : Labeled_Span_Type;
+ Loc : Labeled_Span_Type;
Loc_It : Labeled_Span_Lists.Iterator :=
Labeled_Span_Lists.Iterate (L.Spans);
begin
return Count > 1;
end Has_Multiple_Labeled_Spans;
- ---------------------------
- -- Has_Region_Span_Start --
- ---------------------------
+ ---------------------
+ -- Get_Region_Span --
+ ---------------------
- function Has_Region_Span_Start (L : Printable_Line) return Boolean is
+ function Get_Region_Span
+ (Spans : Labeled_Span_List) return Labeled_Span_Type
+ is
Loc : Labeled_Span_Type;
Loc_It : Labeled_Span_Lists.Iterator :=
- Labeled_Span_Lists.Iterate (L.Spans);
-
- Has_Region_Start : Boolean := False;
+ Labeled_Span_Lists.Iterate (Spans);
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;
+ if Loc.Is_Region then
+ return Loc;
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;
+ return No_Labeled_Span_Object;
+ end Get_Region_Span;
------------------
-- Write_Buffer --
------------------
procedure Write_Buffer
- (Buf : Source_Buffer_Ptr;
- First : Source_Ptr;
- Last : Source_Ptr)
+ (Buf : Source_Buffer_Ptr; First : Source_Ptr; Last : Source_Ptr)
is
begin
for Loc in First .. Last loop
-- Write_Buffer_Char --
-----------------------
- procedure Write_Buffer_Char
- (Buf : Source_Buffer_Ptr;
- Loc : Source_Ptr)
- is
+ 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
+ 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;
-- Write_Line_Marker --
-----------------------
- procedure Write_Line_Marker
- (Num : Pos;
- Width : Positive)
- is
+ procedure Write_Line_Marker (Num : Pos; Width : Positive) is
begin
Write_Str (Image (Positive (Num), Width => Width - 2));
Write_Str (" |");
-- Write_Region_Delimiter --
----------------------------
- procedure Write_Region_Delimiter is
+ procedure Write_Region_Delimiter (SGR_Code : String) is
begin
Write_Str (String'(1 .. REGION_OFFSET => ' '));
+ Write_Str (SGR_Code);
Write_Str ("+");
Write_Str (String'(1 .. REGION_ARM_SIZE => '-'));
+ Write_Str (SGR_Reset);
end Write_Region_Delimiter;
----------------------
-- Write_Region_Bar --
----------------------
- procedure Write_Region_Bar is
+ procedure Write_Region_Bar (SGR_Code : String) is
begin
Write_Str (String'(1 .. REGION_OFFSET => ' '));
+ Write_Str (SGR_Code);
Write_Str ("|");
+ Write_Str (SGR_Reset);
Write_Str (String'(1 .. REGION_ARM_SIZE => ' '));
end Write_Region_Bar;
-- Write_Region_Continuation --
-------------------------------
- procedure Write_Region_Continuation is
+ procedure Write_Region_Continuation (SGR_Code : String) is
begin
Write_Str (String'(1 .. REGION_OFFSET => ' '));
+ Write_Str (SGR_Code);
Write_Str (":");
+ Write_Str (SGR_Reset);
Write_Str (String'(1 .. REGION_ARM_SIZE => ' '));
end Write_Region_Continuation;
Loc : Labeled_Span_Type;
S_Ptr : Source_Ptr)
is
- L : Printable_Line;
- L_It : Lines_Lists.Iterator;
+ L : Printable_Line;
+ L_It : Lines_Lists.Iterator;
Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr));
Line_Found : Boolean := False;
---------------------------
procedure Create_Printable_Line
- (Lines : Lines_List;
- Loc : Labeled_Span_Type;
- S_Ptr : Source_Ptr)
+ (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));
+ Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr));
New_Line : constant Printable_Line :=
(First => Get_Line_Start (Buf, S_Ptr),
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
+ if not Found_Greater_Line and then L.Line_Nr > New_Line.Line_Nr then
Found_Greater_Line := True;
Insert_Before_Line := L;
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
+ -- Insert after all the lines have been iterated over to avoid the
+ -- mutation lock in GNAT.Lists.
- null;
- else
+ if not Found_Greater_Line then
Lines_Lists.Append (Lines, New_Line);
end if;
end Create_Printable_Line;
-- Carret positions
Ptr : constant Source_Ptr := Loc.Span.Ptr;
- Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (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));
+ 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));
+ Line_Lst : constant Pos := Pos (Get_Physical_Line_Number (Lst));
begin
Create_Printable_Line (Lines, Loc, Fst);
File_Section_Lists.Append
(Sections,
(File => new String'(To_File_Name (Loc.Span.Ptr)),
+ Ptr => Loc.Span.Ptr,
Lines => Lines));
end Create_File_Section;
--------------------------
function Create_File_Sections
- (Spans : Labeled_Span_List) return File_Section_List
+ (Locations : Labeled_Span_Id) return File_Section_List
is
Loc : Labeled_Span_Type;
- Loc_It : Labeled_Span_Lists.Iterator :=
- Labeled_Span_Lists.Iterate (Spans);
+ Loc_It : Labeled_Span_Id := Locations;
Sections : File_Section_List := File_Section_Lists.Create;
File_Found : Boolean;
begin
- while Labeled_Span_Lists.Has_Next (Loc_It) loop
- Labeled_Span_Lists.Next (Loc_It, Loc);
+ while Loc_It /= No_Labeled_Span loop
+ Loc := Erroutc.Locations.Table (Loc_It);
File_Found := False;
F_It := File_Section_Lists.Iterate (Sections);
File_Found := True;
Add_Printable_Line (Sec.Lines, Loc, Loc.Span.First);
-
Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Ptr);
-
Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Last);
+
+ if Loc.Is_Primary then
+ Sec.Ptr := Loc.Span.Ptr;
+ end if;
end if;
end loop;
if not File_Found then
Create_File_Section (Sections, Loc);
end if;
+
+ Loc_It := Loc.Next;
end loop;
return Sections;
-- Write_Span_Labels --
-----------------------
- procedure Write_Span_Labels (Loc : Labeled_Span_Type;
- L : Printable_Line;
- Line_Size : Integer;
- Idx : String;
- Within_Region_Span : Boolean)
+ procedure Write_Span_Labels
+ (Loc : Labeled_Span_Type;
+ L : Printable_Line;
+ Line_Size : Integer;
+ Idx : String;
+ Within_Region_Span : Boolean;
+ SGR_Code : String;
+ Region_Span_SGR_Code : String)
is
Span_Char : constant Character := (if Loc.Is_Primary then '~' else '-');
Buf : constant Source_Buffer_Ptr :=
Source_Text (Get_Source_File_Index (L.First));
- Col_L_Fst : constant Natural := Natural
- (Get_Column_Number (Get_First_Line_Char (Buf, L.First)));
- Col_L_Lst : constant Natural := Natural
- (Get_Column_Number (Get_Last_Line_Char (Buf, L.Last)));
+ Col_L_Fst : constant Natural :=
+ Natural (Get_Column_Number (Get_First_Line_Char (Buf, L.First)));
+ Col_L_Lst : constant Natural :=
+ Natural (Get_Column_Number (Get_Last_Line_Char (Buf, L.Last)));
-- Carret positions
Ptr : constant Source_Ptr := Loc.Span.Ptr;
(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
+ (if Line_Ptr = L.Line_Nr then Span_Ptr_Fst + Span_Sym'Length
else Span_Fst);
begin
Write_Empty_Bar_Line (Line_Size);
if Within_Region_Span then
- Write_Region_Bar;
+ Write_Region_Bar (Region_Span_SGR_Code);
else
Write_Region_Offset;
end if;
Write_Str (String'(1 .. Span_Fst - 1 => ' '));
+ Write_Str (SGR_Code);
+
if Line_Ptr = L.Line_Nr then
Write_Str (String'(Span_Fst .. Col_Ptr - 1 => Span_Char));
Write_Str (Span_Sym);
Write_Str (String'(Span_Ptr_Lst .. Span_Lst => Span_Char));
+ Write_Str (SGR_Reset);
+
Write_Eol;
-- Write the label under the line unless it is an intersecting span.
Write_Empty_Bar_Line (Line_Size);
if Within_Region_Span then
- Write_Region_Bar;
+ Write_Region_Bar (Region_Span_SGR_Code);
else
Write_Region_Offset;
end if;
Write_Str (String'(1 .. Span_Fst - 1 => ' '));
+ Write_Str (SGR_Code);
Write_Str (Loc.Label.all);
+ Write_Str (SGR_Reset);
Write_Eol;
end if;
else
if Line_Lst = L.Line_Nr then
Write_Empty_Bar_Line (Line_Size);
Write_Str (String'(1 .. REGION_OFFSET => ' '));
+ Write_Str (SGR_Code);
Write_Str (Loc.Label.all);
+ Write_Str (SGR_Reset);
Write_Eol;
end if;
end if;
-
end Write_Span_Labels;
-------------------
-------------------
function Trimmed_Image (I : Natural) return String is
- Img_Raw : constant String := Natural'Image (I);
+ Img_Raw : constant String := Natural'Image (I);
begin
return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last);
end Trimmed_Image;
-------------------------------
procedure Write_Intersecting_Labels
- (Intersecting_Labels : Labeled_Span_List)
+ (Intersecting_Labels : Labeled_Span_List; SGR_Code : String)
is
- Ls : Labeled_Span_Type;
- Ls_It : Labeled_Span_Lists.Iterator :=
+ L : Labeled_Span_Type;
+ L_It : Labeled_Span_Lists.Iterator :=
Labeled_Span_Lists.Iterate (Intersecting_Labels);
- Idx : Integer := 0;
+ Idx : Integer := 0;
begin
- while Labeled_Span_Lists.Has_Next (Ls_It) loop
- Labeled_Span_Lists.Next (Ls_It, Ls);
+ while Labeled_Span_Lists.Has_Next (L_It) loop
+ Labeled_Span_Lists.Next (L_It, L);
Idx := Idx + 1;
Write_Empty_Bar_Line (MAX_BAR_POS);
Write_Str (" ");
+ Write_Str ((if L.Is_Primary then SGR_Code else SGR_Note));
Write_Int (Int (Idx));
Write_Str (": ");
- Write_Str (Ls.Label.all);
+ Write_Str (L.Label.all);
+ Write_Str (SGR_Reset);
Write_Eol;
end loop;
end Write_Intersecting_Labels;
-- Write_File_Section --
------------------------
- procedure Write_File_Section (Sec : File_Sections;
- Write_File_Name : Boolean;
- File_Name_Offset : Integer)
+ procedure Write_File_Section
+ (Sec : File_Sections; Write_File_Name : Boolean;
+ File_Name_Offset : Integer; Include_Spans : Boolean;
+ SGR_Code : String := SGR_Note)
is
use Lines_Lists;
- L : Printable_Line;
- L_It : Iterator := Iterate (Sec.Lines);
+ function Get_SGR_Code (L : Labeled_Span_Type) return String is
+ (if L.Is_Primary then SGR_Code else SGR_Note);
- -- 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);
+ L : Printable_Line;
+ L_It : Iterator := Iterate (Sec.Lines);
Multiple_Labeled_Spans : Boolean := False;
-- offset the file start location for sub-diagnostics
Write_Str (String'(1 .. File_Name_Offset => ' '));
- Write_Str ("--> " & To_String (Loc.Span.Ptr));
+ Write_Str ("--> " & To_String (Sec.Ptr));
Write_Eol;
end if;
+ -- Historically SPARK does not include spans in their info messages.
+
+ if not Include_Spans then
+ return;
+ end if;
+
while Has_Next (L_It) loop
Next (L_It, L);
declare
- Line_Nr : constant Pos := L.Line_Nr;
+ Line_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 : Labeled_Span_Type;
Loc_It : Labeled_Span_Lists.Iterator :=
Labeled_Span_Lists.Iterate (L.Spans);
Buf : constant Source_Buffer_Ptr :=
Source_Text (Get_Source_File_Index (L.First));
+ Region_Span : constant Labeled_Span_Type :=
+ Get_Region_Span (L.Spans);
+
Contains_Region_Span_Start : constant Boolean :=
- Has_Region_Span_Start (L);
+ Region_Span /= No_Labeled_Span_Object
+ and then Line_Nr =
+ Pos (Get_Physical_Line_Number (Region_Span.Span.First));
Contains_Region_Span_End : constant Boolean :=
- Has_Region_Span_End (L);
+ Region_Span /= No_Labeled_Span_Object
+ and then Line_Nr =
+ Pos (Get_Physical_Line_Number (Region_Span.Span.Last));
+
+ Region_Span_Color : constant String :=
+ (if Region_Span /= No_Labeled_Span_Object then
+ Get_SGR_Code (Region_Span)
+ else SGR_Note);
begin
if not Multiple_Labeled_Spans then
- Multiple_Labeled_Spans := Has_Multiple_Labeled_Spans (L);
+ 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
+ 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;
+ Write_Region_Continuation (Region_Span_Color);
end if;
Write_Eol;
-- whitespaces.
if Contains_Region_Span_Start or Contains_Region_Span_End then
- Write_Region_Delimiter;
+ Write_Region_Delimiter (Region_Span_Color);
elsif Within_Region_Span then
- Write_Region_Bar;
+ Write_Region_Bar (Region_Span_Color);
else
Write_Region_Offset;
end if;
-- Write the line itself
- Write_Buffer
- (Buf => Buf,
- First => L.First,
- Last => L.Last);
+ Write_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
+ if Multiple_Labeled_Spans and then Loc.Label /= null then
-- Collect all the spans with labels to print them at the
-- end.
Idx := Idx + 1;
- Write_Span_Labels (Loc,
- L,
- Line_Size,
- Trimmed_Image (Idx),
- Within_Region_Span);
+ Write_Span_Labels
+ (Loc => Loc,
+ L => L,
+ Line_Size => Line_Size,
+ Idx => Trimmed_Image (Idx),
+ Within_Region_Span => Within_Region_Span,
+ SGR_Code => Get_SGR_Code (Loc),
+ Region_Span_SGR_Code => Region_Span_Color);
else
- Write_Span_Labels (Loc,
- L,
- Line_Size,
- "",
- Within_Region_Span);
+ Write_Span_Labels
+ (Loc => Loc,
+ L => L,
+ Line_Size => Line_Size,
+ Idx => "",
+ Within_Region_Span => Within_Region_Span,
+ SGR_Code => Get_SGR_Code (Loc),
+ Region_Span_SGR_Code => Region_Span_Color);
end if;
end loop;
end;
end loop;
- Write_Intersecting_Labels (Intersecting_Labels);
+ Write_Intersecting_Labels (Intersecting_Labels, SGR_Code);
end Write_File_Section;
-------------------------
-- Write_Labeled_Spans --
-------------------------
- procedure Write_Labeled_Spans (Spans : Labeled_Span_List;
- Write_File_Name : Boolean;
- File_Name_Offset : Integer)
+ procedure Write_Labeled_Spans
+ (Locations : Labeled_Span_Id;
+ Write_File_Name : Boolean;
+ File_Name_Offset : Integer;
+ Include_Spans : Boolean := True;
+ SGR_Code : String := SGR_Note)
is
- Sections : File_Section_List := Create_File_Sections (Spans);
+ Sections : File_Section_List := Create_File_Sections (Locations);
Sec : File_Sections;
F_It : File_Section_Lists.Iterator :=
File_Section_Lists.Next (F_It, Sec);
Write_File_Section
- (Sec, Write_File_Name, File_Name_Offset);
+ (Sec => Sec,
+ Write_File_Name => Write_File_Name,
+ File_Name_Offset => File_Name_Offset,
+ Include_Spans => Include_Spans,
+ SGR_Code => SGR_Code);
end loop;
File_Section_Lists.Destroy (Sections);
-- 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);
+ procedure Write_Error_Msg_Line (E_Msg : Error_Msg_Object) is
+ Switch_Str : constant String := Get_Doc_Switch (E_Msg);
- 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);
+ SGR_Code : constant String := Get_SGR_Code (E_Msg);
begin
Write_Str (SGR_Code);
- Write_Str ("[" & To_String (Diag.Id) & "]");
+ if not GNATprove_Mode or else E_Msg.Id /= No_Diagnostic_Id then
+ Write_Str ("[" & To_String (E_Msg.Id) & "]");
+ end if;
- Write_Str (" " & Kind_To_String (Diag) & ": ");
+ Write_Str (" " & Kind_To_String (E_Msg) & ": ");
Write_Str (SGR_Reset);
- Write_Str (Diag.Message.all);
+ Write_Str (E_Msg.Text.all);
if Switch_Str /= "" then
Write_Str (" " & Switch_Str);
end if;
- if Diag.Warn_Err then
+ if E_Msg.Warn_Err then
Write_Str (" [warning-as-error]");
end if;
-- Should_Write_File_Name --
----------------------------
- function Should_Write_File_Name (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type)
- return Boolean
+ function Should_Write_File_Name
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean
is
- Sub_Loc : constant Labeled_Span_Type := Primary_Location (Sub_Diag);
- Diag_Loc : constant Labeled_Span_Type := Primary_Location (Diag);
+ Sub_Loc : constant Labeled_Span_Type :=
+ Locations.Table (Primary_Location (Sub_Diag));
+
+ Diag_Loc : constant Labeled_Span_Type :=
+ Locations.Table (Primary_Location (Diag));
- function Has_Multiple_Files (Spans : Labeled_Span_List) return Boolean;
+ function Has_Multiple_Files (Diag : Error_Msg_Object) return Boolean;
------------------------
-- Has_Multiple_Files --
------------------------
- function Has_Multiple_Files
- (Spans : Labeled_Span_List) return Boolean
- is
+ function Has_Multiple_Files (Diag : Error_Msg_Object) return Boolean is
First : constant Labeled_Span_Type :=
- Labeled_Span_Lists.First (Spans);
+ Locations.Table (Diag.Locations);
File : constant String := To_File_Name (First.Span.Ptr);
- Loc : Labeled_Span_Type;
- It : Labeled_Span_Lists.Iterator :=
- Labeled_Span_Lists.Iterate (Spans);
-
+ Loc_Id : Labeled_Span_Id := Diag.Locations;
+ Loc : Labeled_Span_Type;
begin
- while Labeled_Span_Lists.Has_Next (It) loop
- Labeled_Span_Lists.Next (It, Loc);
+ Loc_Id := Diag.Locations;
+ while Loc_Id /= No_Labeled_Span loop
+ Loc := Locations.Table (Loc_Id);
if To_File_Name (Loc.Span.Ptr) /= File then
return True;
end if;
+
+ Loc_Id := Loc.Next;
end loop;
+
return False;
end Has_Multiple_Files;
+
+ -- Start of processing for Should_Write_File_Name
+
begin
return
- Has_Multiple_Files (Diag.Locations)
+ Has_Multiple_Files (Diag)
or else To_File_Name (Sub_Loc.Span.Ptr) /=
To_File_Name (Diag_Loc.Span.Ptr);
end Should_Write_File_Name;
-- Should_Write_Spans --
------------------------
- function Should_Write_Spans (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type)
- return Boolean
+ function Should_Write_Spans
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object) return Boolean
is
- Sub_Loc : constant Labeled_Span_Type := Primary_Location (Sub_Diag);
- Diag_Loc : constant Labeled_Span_Type := Primary_Location (Diag);
+ Sub_Loc : constant Labeled_Span_Id := Primary_Location (Sub_Diag);
+ Diag_Loc : constant Labeled_Span_Id := Primary_Location (Diag);
begin
- return Sub_Loc /= No_Labeled_Span
- and then Diag_Loc /= No_Labeled_Span
- and then Sub_Loc.Span.Ptr /= Diag_Loc.Span.Ptr;
+ return
+ Sub_Loc /= No_Labeled_Span and then Diag_Loc /= No_Labeled_Span
+ and then Locations.Table (Sub_Loc).Span.Ptr /=
+ Locations.Table (Diag_Loc).Span.Ptr;
end Should_Write_Spans;
----------------
procedure Print_Edit (Edit : Edit_Type; Offset : Integer) is
Buf : constant Source_Buffer_Ptr :=
- Source_Text (Get_Source_File_Index (Edit.Span.Ptr));
+ Source_Text (Get_Source_File_Index (Edit.Span.Ptr));
Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (Edit.Span.Ptr));
Write_Char ('-');
Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1);
- Write_Buffer
- (Buf => Buf,
- First => Line_Fst,
- Last => Line_Lst);
+ Write_Buffer (Buf => Buf, First => Line_Fst, Last => Line_Lst);
-- write the edited line
Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1);
Write_Buffer
- (Buf => Buf,
- First => Line_Fst,
- Last => Edit.Span.First - 1);
+ (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);
-
+ Write_Buffer (Buf => Buf, First => Edit.Span.Last + 1, Last => Line_Lst);
end Print_Edit;
---------------
---------------
procedure Print_Fix (Fix : Fix_Type; Offset : Integer) is
- use Edit_Lists;
+ E : Edit_Id;
begin
Write_Str (String'(1 .. Offset => ' '));
Write_Str ("+ Fix: ");
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);
+ E := Fix.Edits;
+ while E /= No_Edit loop
+ Print_Edit (Edits.Table (E), MAX_BAR_POS - 1);
- Print_Edit (Edit, MAX_BAR_POS - 1);
- end loop;
- end;
- end if;
+ E := Edits.Table (E).Next;
+ end loop;
end Print_Fix;
--------------------------
--------------------------
procedure Print_Sub_Diagnostic
- (Sub_Diag : Sub_Diagnostic_Type;
- Diag : Diagnostic_Type;
- Offset : Integer)
+ (Sub_Diag : Error_Msg_Object; Diag : Error_Msg_Object; 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 ("+ ");
- Write_Str (Sub_Diag.Message.all);
+ Write_Str (Sub_Diag.Text.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);
+ Write_Labeled_Spans
+ (Locations => Sub_Diag.Locations,
+ Write_File_Name => Should_Write_File_Name (Sub_Diag, Diag),
+ File_Name_Offset => Offset,
+ Include_Spans => not GNATprove_Mode or else Sub_Diag.Kind /= Info,
+ SGR_Code => SGR_Note);
end if;
end Print_Sub_Diagnostic;
-- Print_Diagnostic --
----------------------
- procedure Print_Diagnostic (Diag : Diagnostic_Type) is
+ procedure Print_Diagnostic (E : Error_Msg_Id) is
+ E_Msg : constant Error_Msg_Object := Errors.Table (E);
+
+ E_Next_Id : Error_Msg_Id;
+ F : Fix_Id;
begin
-- Print the main diagnostic
- Write_Error_Msg_Line (Diag);
+ Write_Error_Msg_Line (E_Msg);
-- Print diagnostic locations along with spans
- Write_Labeled_Spans (Diag.Locations, True, 0);
+ Write_Labeled_Spans
+ (Locations => E_Msg.Locations,
+ Write_File_Name => True,
+ File_Name_Offset => 0,
+ Include_Spans => not GNATprove_Mode or else E_Msg.Kind /= Info,
+ SGR_Code => Get_SGR_Code (E_Msg));
-- Print subdiagnostics
- 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
+ E_Next_Id := E_Msg.Next;
+ while E_Next_Id /= No_Error_Msg
+ and then Errors.Table (E_Next_Id).Msg_Cont
+ loop
+ -- Print the subdiagnostic and offset the location of the file
+ -- name
+ Print_Sub_Diagnostic
+ (Errors.Table (E_Next_Id), E_Msg, MAX_BAR_POS - 1);
- Print_Sub_Diagnostic (Sub_Diag, Diag, MAX_BAR_POS - 1);
- end loop;
- end;
- end if;
+ E_Next_Id := Errors.Table (E_Next_Id).Next;
+ end loop;
-- 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);
+ F := E_Msg.Fixes;
+ while F /= No_Fix loop
+ Print_Fix (Fixes.Table (F), MAX_BAR_POS - 1);
- Print_Fix (Fix, MAX_BAR_POS - 1);
- end loop;
- end;
- end if;
+ F := Fixes.Table (F).Next;
+ end loop;
-- Separate main diagnostics with a blank line
Write_Eol;
-
end Print_Diagnostic;
-end Diagnostics.Pretty_Emitter;
+
+ --------------------------
+ -- Print_Error_Messages --
+ --------------------------
+
+ procedure Print_Error_Messages is
+ E : Error_Msg_Id;
+ begin
+ Set_Standard_Error;
+
+ E := First_Error_Msg;
+ while E /= No_Error_Msg loop
+
+ if not Errors.Table (E).Deleted and then not Errors.Table (E).Msg_Cont
+ then
+ Print_Diagnostic (E);
+ end if;
+
+ E := Errors.Table (E).Next;
+ end loop;
+
+ Set_Standard_Output;
+ end Print_Error_Messages;
+
+ ------------------
+ -- To_File_Name --
+ ------------------
+
+ function To_File_Name (Sptr : Source_Ptr) return String is
+ Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr);
+ Ref_Name : constant File_Name_Type :=
+ (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile)
+ else Reference_Name (Sfile));
+
+ begin
+ return Get_Name_String (Ref_Name);
+ end To_File_Name;
+
+ --------------------
+ -- Line_To_String --
+ --------------------
+
+ function Line_To_String (Sptr : Source_Ptr) return String is
+ Line : constant Logical_Line_Number := Get_Logical_Line_Number (Sptr);
+ Img_Raw : constant String := Int'Image (Int (Line));
+
+ begin
+ return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last);
+ end Line_To_String;
+
+ ----------------------
+ -- Column_To_String --
+ ----------------------
+
+ function Column_To_String (Sptr : Source_Ptr) return String is
+ Col : constant Column_Number := Get_Column_Number (Sptr);
+ Img_Raw : constant String := Int'Image (Int (Col));
+
+ begin
+ return
+ (if Col < 10 then "0" else "") &
+ Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last);
+ end Column_To_String;
+
+ ---------------
+ -- To_String --
+ ---------------
+
+ function To_String (Sptr : Source_Ptr) return String is
+ begin
+ return
+ To_File_Name (Sptr) & ":" & Line_To_String (Sptr) & ":" &
+ Column_To_String (Sptr);
+ end To_String;
+
+end Erroutc.Pretty_Emitter;
-- --
------------------------------------------------------------------------------
-package Diagnostics.Pretty_Emitter is
- procedure Print_Diagnostic (Diag : Diagnostic_Type);
-end Diagnostics.Pretty_Emitter;
+package Erroutc.Pretty_Emitter is
+ procedure Print_Error_Messages;
+end Erroutc.Pretty_Emitter;
-- --
------------------------------------------------------------------------------
-with Errout; use Errout;
-with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils;
-with Diagnostics.Utils; use Diagnostics.Utils;
-with Gnatvsn; use Gnatvsn;
-with Lib; use Lib;
-with Namet; use Namet;
-with Osint; use Osint;
-with Output; use Output;
-with Sinput; use Sinput;
+with JSON_Utils; use JSON_Utils;
+with GNAT.Lists; use GNAT.Lists;
+with Gnatvsn; use Gnatvsn;
+with Lib; use Lib;
+with Namet; use Namet;
+with Osint; use Osint;
+with Output; use Output;
+with Sinput; use Sinput;
with System.OS_Lib;
-package body Diagnostics.SARIF_Emitter is
+package body Erroutc.SARIF_Emitter is
-- SARIF attribute names
SARIF_Version : constant String := "2.1.0";
pragma Style_Checks ("M100");
- SARIF_Schema : constant String :=
+ SARIF_Schema : constant String :=
"https://docs.oasis-open.org/sarif/sarif/v2.1.0/errata01/os/schemas/sarif-schema-2.1.0.json";
pragma Style_Checks ("M79");
-- and it is also the path that all other Uri attributes will be created
-- relative to.
+ procedure Destroy (Elem : in out Error_Msg_Object) is null;
+ pragma Inline (Destroy);
+ package Error_Msg_Lists is new Doubly_Linked_Lists
+ (Element_Type => Error_Msg_Object,
+ "=" => "=",
+ Destroy_Element => Destroy,
+ Check_Tampering => False);
+
+ subtype Error_Msg_List is Error_Msg_Lists.Doubly_Linked_List;
+
+ procedure Destroy (Elem : in out Edit_Type);
+
+ procedure Destroy (Elem : in out Edit_Type) is
+ begin
+ -- Diagnostic elements will be freed when all the diagnostics have been
+ -- emitted.
+ null;
+ end Destroy;
+
+ 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 Artifact_Change is record
- File_Index : Source_File_Index;
+ File_Index : Source_File_Index;
-- Index for the source file
Replacements : Edit_List;
-- Regions of texts to be edited
end record;
- procedure Destroy (Elem : in out Artifact_Change) is null;
+ procedure Destroy (Elem : in out Artifact_Change);
pragma Inline (Destroy);
function Equals (L, R : Artifact_Change) return Boolean is
-- 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;
+ function Get_Unique_Rules return Error_Msg_List;
-- Get a list of diagnostics that have unique Diagnostic Id-s.
procedure Print_Replacement (Replacement : Edit_Type);
-- artifactChanges: [<ArtifactChange>]
-- }
- procedure Print_Fixes (Diag : Diagnostic_Type);
+ procedure Print_Fixes (E_Msg : Error_Msg_Object);
-- Print the fixes node
--
-- "fixes": [
-- "uriBaseId": "PWD"
-- }
- procedure Print_Location (Loc : Labeled_Span_Type;
- Msg : String_Ptr);
+ procedure Print_Location (Loc : Labeled_Span_Type; Msg : String_Ptr);
-- Print a location node that consists of
-- * an optional message node
-- * a physicalLocation node
-- }
-- }
- procedure Print_Locations (Diag : Diagnostic_Type);
+ procedure Print_Locations (E_Msg : Error_Msg_Object);
-- Print a locations node that consists of multiple location nodes. However
-- typically just one location for the primary span of the diagnostic.
--
-- }
-- },
- procedure Print_Related_Locations (Diag : Diagnostic_Type);
+ procedure Print_Related_Locations (E_Msg : Error_Msg_Object);
-- 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.
-- <Location (Diag.Loc)>
-- ],
- procedure Print_Region (Start_Line : Int;
- Start_Col : Int;
- End_Line : Int;
- End_Col : Int;
- Name : String := N_REGION);
+ procedure Print_Region
+ (Start_Line : Int;
+ Start_Col : Int;
+ End_Line : Int;
+ End_Col : Int;
+ Name : String := N_REGION);
-- Print a region node.
--
-- More specifically a text region node that specifies the textual
-- the GNAT span definition and we amend the endColumn value so that it
-- matches the SARIF definition.
- procedure Print_Result (Diag : Diagnostic_Type);
+ procedure Print_Result (E_Msg : Error_Msg_Object);
-- {
-- "ruleId": <Diag.Id>,
-- "level": <Diag.Kind>,
-- "relatedLocations": [<Secondary_Locations>]
-- },
- procedure Print_Results (Diags : Diagnostic_List);
+ procedure Print_Results;
-- Print a results node that consists of multiple result nodes for each
-- diagnostic instance.
--
-- <Result (Diag)>
-- ]
- procedure Print_Rule (Diag : Diagnostic_Type);
+ procedure Print_Rule (E : Error_Msg_Object);
-- Print a rule node that consists of the following attributes:
-- * ruleId
-- * name
-- "name": <Human_Id(Diag)>
-- },
- procedure Print_Rules (Diags : Diagnostic_List);
+ procedure Print_Rules;
-- 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.
-- <Rule (Diag)>
-- ]
- procedure Print_Runs (Diags : Diagnostic_List);
+ procedure Print_Runs;
-- 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
-- "results": [<Results (Diags)>]
-- }
- procedure Print_Tool (Diags : Diagnostic_List);
+ procedure Print_Tool;
-- Print a tool node that consists of
-- * a driver node that consists of:
-- * name
-- }
-- }
+ -------------
+ -- Destroy --
+ -------------
+
+ procedure Destroy (Elem : in out Artifact_Change) is
+ begin
+ Edit_Lists.Destroy (Elem.Replacements);
+ end Destroy;
+
--------------------------
-- Get_Artifact_Changes --
--------------------------
-- Insert --
------------
- procedure Insert (Changes : Artifact_Change_List; E : Edit_Type)
- is
+ procedure Insert (Changes : Artifact_Change_List; E : Edit_Type) is
A : Artifact_Change;
It : Artifact_Change_Lists.Iterator :=
Edit_Lists.Append (Replacements, E);
Artifact_Change_Lists.Append
(Changes,
- (File_Index => Get_Source_File_Index (E.Span.Ptr),
+ (File_Index => Get_Source_File_Index (E.Span.Ptr),
Replacements => Replacements));
end;
end Insert;
E : Edit_Type;
- It : Edit_Lists.Iterator := Edit_Lists.Iterate (Fix.Edits);
+ It : Edit_Id;
+
+ -- Start of processing for Get_Artifact_Changes
+
begin
- while Edit_Lists.Has_Next (It) loop
- Edit_Lists.Next (It, E);
+ It := Fix.Edits;
+
+ while It /= No_Edit loop
+ E := Edits.Table (It);
Insert (Changes, E);
+
+ It := E.Next;
end loop;
return Changes;
-- Get_Unique_Rules --
----------------------
- function Get_Unique_Rules (Diags : Diagnostic_List)
- return Diagnostic_List
- is
- use Diagnostics.Diagnostics_Lists;
+ function Get_Unique_Rules return Error_Msg_List is
+ use Error_Msg_Lists;
- procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type);
+ procedure Insert (Rules : Error_Msg_List; E : Error_Msg_Object);
------------
-- Insert --
------------
- procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type) is
+ procedure Insert (Rules : Error_Msg_List; E : Error_Msg_Object) is
It : Iterator := Iterate (Rules);
- R : Diagnostic_Type;
+ R : Error_Msg_Object;
begin
while Has_Next (It) loop
Next (It, R);
- if R.Id = D.Id then
+ if R.Id = E.Id then
return;
- elsif R.Id > D.Id then
- Insert_Before (Rules, R, D);
+ elsif R.Id > E.Id then
+ Insert_Before (Rules, R, E);
return;
end if;
end loop;
- Append (Rules, D);
+ Append (Rules, E);
end Insert;
- D : Diagnostic_Type;
- Unique_Rules : constant Diagnostic_List := Create;
+ Unique_Rules : constant Error_Msg_List := Create;
+
+ E : Error_Msg_Id;
+
+ -- Start of processing for Get_Unique_Rules
- 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;
+ E := First_Error_Msg;
+ while E /= No_Error_Msg loop
+ Insert (Unique_Rules, Errors.Table (E));
+
+ Next_Error_Msg (E);
+ end loop;
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;
+ procedure Print_Artifact_Change (A : Artifact_Change) is
+ use Edit_Lists;
+ E : Edit_Type;
E_It : Iterator;
First : Boolean := True;
and then Abs_Name (Abs_Name'First) =
Current_Dir (Current_Dir'First)
then
- Write_String_Attribute
- (N_URI, To_File_Uri (Abs_Name));
+ Write_String_Attribute (N_URI, To_File_Uri (Abs_Name));
else
Write_String_Attribute
- (N_URI,
- To_File_Uri
- (Relative_Path (Abs_Name, Current_Dir)));
+ (N_URI, To_File_Uri (Relative_Path (Abs_Name, Current_Dir)));
Write_Char (',');
NL_And_Indent;
- Write_String_Attribute
- (N_URI_BASE_ID, URI_Base_Id_Name);
+ Write_String_Attribute (N_URI_BASE_ID, URI_Base_Id_Name);
end if;
end;
else
-- Print deletedRegion
- Print_Region (Start_Line => Line_Fst,
- Start_Col => Col_Fst,
- End_Line => Line_Lst,
- End_Col => Col_Lst,
- Name => N_DELETED_REGION);
+ Print_Region
+ (Start_Line => Line_Fst,
+ Start_Col => Col_Fst,
+ End_Line => Line_Lst,
+ End_Col => Col_Lst,
+ Name => N_DELETED_REGION);
if Replacement.Text /= null then
Write_Char (',');
use Artifact_Change_Lists;
Changes : Artifact_Change_List := Get_Artifact_Changes (Fix);
A : Artifact_Change;
- A_It : Iterator := Iterate (Changes);
+ A_It : Iterator := Iterate (Changes);
begin
Write_Str ("""" & N_ARTIFACT_CHANGES & """" & ": " & "[");
Begin_Block;
-- Print_Fixes --
-----------------
- procedure Print_Fixes (Diag : Diagnostic_Type) is
- use Diagnostics.Fix_Lists;
- F : Fix_Type;
- F_It : Iterator;
+ procedure Print_Fixes (E_Msg : Error_Msg_Object) is
+ F : Fix_Type;
+ F_It : Fix_Id;
First : Boolean := True;
begin
Write_Str ("""" & N_FIXES & """" & ": " & "[");
Begin_Block;
- if Present (Diag.Fixes) then
- F_It := Iterate (Diag.Fixes);
- while Has_Next (F_It) loop
- Next (F_It, F);
+ F_It := E_Msg.Fixes;
+ while F_It /= No_Fix loop
+ F := Fixes.Table (F_It);
- if First then
- First := False;
- else
- Write_Char (',');
- end if;
+ if First then
+ First := False;
+ else
+ Write_Char (',');
+ end if;
- NL_And_Indent;
- Print_Fix (F);
- end loop;
- end if;
+ NL_And_Indent;
+ Print_Fix (F);
+
+ F_It := F.Next;
+ end loop;
End_Block;
NL_And_Indent;
-- Print_Region --
------------------
- procedure Print_Region (Start_Line : Int;
- Start_Col : Int;
- End_Line : Int;
- End_Col : Int;
- Name : String := N_REGION)
+ procedure Print_Region
+ (Start_Line : Int;
+ Start_Col : Int;
+ End_Line : Int;
+ End_Col : Int;
+ Name : String := N_REGION)
is
begin
-- Print_Location --
--------------------
- procedure Print_Location (Loc : Labeled_Span_Type;
- Msg : String_Ptr)
- is
+ procedure Print_Location (Loc : Labeled_Span_Type; Msg : String_Ptr) is
-- Span start positions
Fst : constant Source_Ptr := Loc.Span.First;
-- Print region
- Print_Region (Start_Line => Line_Fst,
- Start_Col => Col_Fst,
- End_Line => Line_Lst,
- End_Col => Col_Lst);
+ Print_Region
+ (Start_Line => Line_Fst,
+ Start_Col => Col_Fst,
+ End_Line => Line_Lst,
+ End_Col => Col_Lst);
End_Block;
NL_And_Indent;
-- Print_Locations --
---------------------
- procedure Print_Locations (Diag : Diagnostic_Type) is
- use Diagnostics.Labeled_Span_Lists;
+ procedure Print_Locations (E_Msg : Error_Msg_Object) is
Loc : Labeled_Span_Type;
- It : Iterator := Iterate (Diag.Locations);
+ It : Labeled_Span_Id;
First : Boolean := True;
begin
Write_Str ("""" & N_LOCATIONS & """" & ": " & "[");
Begin_Block;
- while Has_Next (It) loop
- Next (It, Loc);
+ It := E_Msg.Locations;
+ while It /= No_Labeled_Span loop
+ Loc := Locations.Table (It);
-- Only the primary span is considered as the main location other
-- spans are considered related locations
NL_And_Indent;
Print_Location (Loc, Loc.Label);
end if;
+
+ It := Loc.Next;
end loop;
End_Block;
NL_And_Indent;
Write_Char (']');
-
end Print_Locations;
-------------------
-- 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);
+ procedure Print_Related_Locations (E_Msg : Error_Msg_Object) is
+ Loc : Labeled_Span_Type;
+ Loc_It : Labeled_Span_Id;
- Sub : Sub_Diagnostic_Type;
- Sub_It : Sub_Diagnostic_Lists.Iterator;
+ Sub : Error_Msg_Object;
+ Sub_It : Error_Msg_Id;
First : Boolean := True;
begin
-- 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);
+ Loc_It := E_Msg.Locations;
+ while Loc_It /= No_Labeled_Span loop
+ Loc := Locations.Table (Loc_It);
-- Non-primary spans are considered related locations
NL_And_Indent;
Print_Location (Loc, Loc.Label);
end if;
+ Loc_It := Loc.Next;
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);
+ Sub_It := E_Msg.Next;
+ while Sub_It /= No_Error_Msg and then Errors.Table (Sub_It).Msg_Cont loop
+ Sub := Errors.Table (Sub_It);
- declare
- Found : Boolean := False;
+ 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
+ Prim_Loc_Id : Labeled_Span_Id;
+ begin
+ Prim_Loc_Id := Primary_Location (Sub);
- -- If there are no locations for the sub-diagnostic then use
- -- the primary location of the main diagnostic.
+ if Prim_Loc_Id /= No_Labeled_Span then
+ Found := True;
+ else
+ Prim_Loc_Id := Primary_Location (E_Msg);
+ Found := True;
+ end if;
- Found := True;
- Prim_Loc := Primary_Location (Diag);
+ -- 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 (Locations.Table (Prim_Loc_Id), Sub.Text);
+ end if;
+ end;
- -- 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;
+ Next_Continuation_Msg (Sub_It);
+ end loop;
End_Block;
NL_And_Indent;
Write_Char (']');
-
end Print_Related_Locations;
------------------
-- Print_Result --
------------------
- procedure Print_Result (Diag : Diagnostic_Type) is
+ procedure Print_Result (E_Msg : Error_Msg_Object) is
begin
Write_Char ('{');
-- Print ruleId
- Write_String_Attribute (N_RULE_ID, "[" & To_String (Diag.Id) & "]");
+ Write_String_Attribute (N_RULE_ID, "[" & To_String (E_Msg.Id) & "]");
Write_Char (',');
NL_And_Indent;
-- Print level
- Write_String_Attribute (N_LEVEL, Kind_To_String (Diag));
+ Write_String_Attribute (N_LEVEL, Kind_To_String (E_Msg));
Write_Char (',');
NL_And_Indent;
-- Print message
- Print_Message (Diag.Message.all);
+ Print_Message (E_Msg.Text.all);
Write_Char (',');
NL_And_Indent;
-- Print locations
- Print_Locations (Diag);
+ Print_Locations (E_Msg);
Write_Char (',');
NL_And_Indent;
-- Print related locations
- Print_Related_Locations (Diag);
+ Print_Related_Locations (E_Msg);
Write_Char (',');
NL_And_Indent;
-- Print fixes
- Print_Fixes (Diag);
+ Print_Fixes (E_Msg);
End_Block;
NL_And_Indent;
-- Print_Results --
-------------------
- procedure Print_Results (Diags : Diagnostic_List) is
- use Diagnostics.Diagnostics_Lists;
-
- D : Diagnostic_Type;
-
- It : Iterator := Iterate (All_Diagnostics);
+ procedure Print_Results is
+ E : Error_Msg_Id;
First : Boolean := True;
begin
Write_Str ("""" & N_RESULTS & """" & ": " & "[");
Begin_Block;
- if Present (Diags) then
- while Has_Next (It) loop
- Next (It, D);
+ E := First_Error_Msg;
+ while E /= No_Error_Msg loop
+ if First then
+ First := False;
+ else
+ Write_Char (',');
+ end if;
- if First then
- First := False;
- else
- Write_Char (',');
- end if;
+ NL_And_Indent;
- NL_And_Indent;
- Print_Result (D);
- end loop;
- end if;
+ Print_Result (Errors.Table (E));
+
+ Next_Error_Msg (E);
+ end loop;
End_Block;
NL_And_Indent;
-- Print_Rule --
----------------
- procedure Print_Rule (Diag : Diagnostic_Type) is
- Human_Id : constant String_Ptr := Get_Human_Id (Diag);
+ procedure Print_Rule (E : Error_Msg_Object) is
+ Human_Id : constant String_Ptr := Get_Human_Id (E);
begin
Write_Char ('{');
Begin_Block;
NL_And_Indent;
- Write_String_Attribute (N_ID, "[" & To_String (Diag.Id) & "]");
+ Write_String_Attribute (N_ID, "[" & To_String (E.Id) & "]");
Write_Char (',');
NL_And_Indent;
-- 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);
+ procedure Print_Rules is
+ use Error_Msg_Lists;
+ R : Error_Msg_Object;
+ Rules : Error_Msg_List := Get_Unique_Rules;
+ It : Iterator := Iterate (Rules);
First : Boolean := True;
begin
NL_And_Indent;
Write_Char (']');
+ Error_Msg_Lists.Destroy (Rules);
end Print_Rules;
----------------
-- Print_Tool --
----------------
- procedure Print_Tool (Diags : Diagnostic_List) is
+ procedure Print_Tool is
begin
Write_Str ("""" & N_TOOL & """" & ": " & "{");
Write_Char (',');
NL_And_Indent;
- Print_Rules (Diags);
+ Print_Rules;
-- End of tool.driver
-- Print_Runs --
----------------
- procedure Print_Runs (Diags : Diagnostic_List) is
+ procedure Print_Runs is
begin
Write_Str ("""" & N_RUNS & """" & ": " & "[");
-- A run consists of a tool
- Print_Tool (Diags);
+ Print_Tool;
Write_Char (',');
NL_And_Indent;
-- A run consists of results
- Print_Results (Diags);
+ Print_Results;
-- End of run
-- Print_SARIF_Report --
------------------------
- procedure Print_SARIF_Report (Diags : Diagnostic_List) is
+ procedure Print_SARIF_Report is
begin
Write_Char ('{');
Begin_Block;
Write_Char (',');
NL_And_Indent;
- Print_Runs (Diags);
+ Print_Runs;
End_Block;
NL_And_Indent;
Write_Eol;
end Print_SARIF_Report;
-end Diagnostics.SARIF_Emitter;
+end Erroutc.SARIF_Emitter;
-- --
------------------------------------------------------------------------------
-package Diagnostics.SARIF_Emitter is
+package Erroutc.SARIF_Emitter is
- procedure Print_SARIF_Report (Diags : Diagnostic_List);
-end Diagnostics.SARIF_Emitter;
+ procedure Print_SARIF_Report;
+end Erroutc.SARIF_Emitter;
E_Msg.Kind in Warning | Info | Style and then E_Msg.Warn_Chr /= " ";
end Has_Switch_Tag;
+ --------------------
+ -- Next_Error_Msg --
+ --------------------
+
+ procedure Next_Error_Msg (E : in out Error_Msg_Id) is
+ begin
+ loop
+ E := Errors.Table (E).Next;
+ exit when E = No_Error_Msg;
+ exit when not Errors.Table (E).Deleted
+ and then not Errors.Table (E).Msg_Cont;
+ end loop;
+ end Next_Error_Msg;
+
+ ---------------------------
+ -- Next_Continuation_Msg --
+ ---------------------------
+
+ procedure Next_Continuation_Msg (E : in out Error_Msg_Id) is
+ begin
+ E := Errors.Table (E).Next;
+
+ if E = No_Error_Msg or else not Errors.Table (E).Msg_Cont then
+ E := No_Error_Msg;
+ end if;
+ end Next_Continuation_Msg;
+
+ ----------------------
+ -- Primary_Location --
+ ----------------------
+
+ function Primary_Location (E : Error_Msg_Object) return Labeled_Span_Id is
+ L : Labeled_Span_Id;
+ begin
+ L := E.Locations;
+ while L /= No_Labeled_Span loop
+ if Locations.Table (L).Is_Primary then
+ return L;
+ end if;
+
+ L := Locations.Table (L).Next;
+ end loop;
+
+ return No_Labeled_Span;
+ end Primary_Location;
+
+ ------------------
+ -- Get_Human_Id --
+ ------------------
+
+ function Get_Human_Id (E : Error_Msg_Object) return String_Ptr is
+ begin
+ if E.Switch = No_Switch_Id then
+ return Diagnostic_Entries (E.Id).Human_Id;
+ else
+ return Get_Switch (E).Human_Id;
+ end if;
+ end Get_Human_Id;
+
+ --------------------
+ -- Get_Doc_Switch --
+ --------------------
+
+ function Get_Doc_Switch (E : Error_Msg_Object) return String is
+ begin
+ if Warning_Doc_Switch
+ and then E.Warn_Chr /= " "
+ and then E.Kind in Info
+ | Style
+ | Warning
+ then
+ if E.Switch = No_Switch_Id then
+ if E.Warn_Chr = "* " then
+ return "[restriction warning]";
+
+ -- Info messages can have a switch tag but they should not have
+ -- a default switch tag.
+
+ elsif E.Kind /= Info then
+
+ -- For Default_Warning
+
+ return "[enabled by default]";
+ end if;
+ else
+ declare
+ S : constant Switch_Type := Get_Switch (E);
+ begin
+ return "[-" & S.Short_Name.all & "]";
+ end;
+ end if;
+ end if;
+
+ return "";
+ end Get_Doc_Switch;
+
+ ----------------
+ -- Get_Switch --
+ ----------------
+
+ function Get_Switch (E : Error_Msg_Object) return Switch_Type is
+ begin
+ return Get_Switch (E.Switch);
+ end Get_Switch;
+
+ -------------------
+ -- Get_Switch_Id --
+ -------------------
+
+ function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is
+ begin
+ return Get_Switch_Id (E.Kind, E.Warn_Chr);
+ end Get_Switch_Id;
+
+ function Get_Switch_Id
+ (Kind : Error_Msg_Type; Warn_Chr : String) return Switch_Id is
+ begin
+ if Warn_Chr = "$ " then
+ return Get_Switch_Id ("gnatel");
+ elsif Kind in Warning | Info then
+ return Get_Switch_Id ("gnatw" & Warn_Chr);
+ elsif Kind = Style then
+ return Get_Switch_Id ("gnaty" & Warn_Chr);
+ else
+ return No_Switch_Id;
+ end if;
+ end Get_Switch_Id;
+
-------------
-- Matches --
-------------
-- Output_Text_Within --
------------------------
- procedure Output_Text_Within (Txt : String_Ptr; Line_Length : Nat) is
+ procedure Output_Text_Within (Txt : String; Line_Length : Nat) is
Offs : constant Nat := Column - 1;
-- Offset to start of message, used for continuations
procedure Output_Msg_Text (E : Error_Msg_Id) is
- E_Msg : Error_Msg_Object renames Errors.Table (E);
- Text : constant String_Ptr := E_Msg.Text;
- Tag : constant String := Get_Warning_Tag (E);
- Txt : String_Ptr;
-
- Line_Length : constant Nat :=
+ E_Msg : Error_Msg_Object renames Errors.Table (E);
+ Text : constant String_Ptr := E_Msg.Text;
+ Tag : constant String := Get_Warning_Tag (E);
+ SGR_Code : constant String := Get_SGR_Code (E_Msg);
+ Kind_Prefix : constant String :=
+ (if E_Msg.Kind = Style then Style_Prefix
+ else Kind_To_String (E_Msg) & ": ");
+ Buf : Bounded_String (Max_Msg_Length);
+ Line_Length : constant Nat :=
(if Error_Msg_Line_Length = 0 then Nat'Last
else Error_Msg_Line_Length);
begin
- -- Postfix warning tag to message if needed
-
- if Tag /= "" and then Warning_Doc_Switch then
- Txt := new String'(Text.all & ' ' & Tag);
- else
- Txt := Text;
- end if;
-
- -- If -gnatdF is used, continuation messages follow the main message
- -- with only an indentation of two space characters, without repeating
- -- any prefix.
-
- if Debug_Flag_FF and then E_Msg.Msg_Cont then
- null;
-
- -- For info messages, prefix message with "info: "
-
- elsif E_Msg.Kind = Info then
- Txt := new String'(SGR_Note & "info: " & SGR_Reset & Txt.all);
+ -- Prefix with "error:" rather than warning.
+ -- Additionally include the style suffix when needed.
- -- Warning treated as error
-
- elsif E_Msg.Warn_Err then
-
- -- We prefix with "error:" rather than warning: and postfix
- -- [warning-as-error] at the end.
+ if E_Msg.Warn_Err then
Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
- Txt := new String'(SGR_Error & "error: " & SGR_Reset
- & Txt.all & " [warning-as-error]");
-
- -- Normal warning, prefix with "warning: "
-
- elsif E_Msg.Kind = Warning then
- Txt := new String'(SGR_Warning & "warning: " & SGR_Reset & Txt.all);
-
- -- No prefix needed for style message, "(style)" is there already
-
- elsif E_Msg.Kind = Style then
- if Txt (Txt'First .. Txt'First + 6) = "(style)" then
- Txt := new String'(SGR_Warning & "(style)" & SGR_Reset
- & Txt (Txt'First + 7 .. Txt'Last));
- end if;
-
- -- No prefix needed for check message, severity is there already
-
- elsif E_Msg.Kind in High_Check | Medium_Check | Low_Check then
- -- The message format is "severity: ..."
- --
- -- Enclose the severity with an SGR control string if requested
-
- if Use_SGR_Control then
- declare
- Msg : String renames Text.all;
- Colon : Natural := 0;
- begin
- -- Find first colon
+ Append
+ (Buf,
+ SGR_Error & "error: " & SGR_Reset &
+ (if E_Msg.Kind = Style then Style_Prefix else ""));
+
+ -- Print the message kind prefix
+ -- * Info/Style/Warning messages
+ -- * Check messages that are not continuations in the pretty printer
+ -- * Error messages when error tags are allowed
+
+ elsif E_Msg.Kind in Info | Style | Warning
+ or else
+ (E_Msg.Kind in High_Check | Medium_Check | Low_Check
+ and then not (E_Msg.Msg_Cont and then Debug_Flag_FF))
+ or else
+ (E_Msg.Kind in Error | Non_Serious_Error
+ and then Opt.Unique_Error_Tag)
+ then
+ Append (Buf, SGR_Code & Kind_Prefix & SGR_Reset);
+ end if;
- for J in Msg'Range loop
- if Msg (J) = ':' then
- Colon := J;
- exit;
- end if;
- end loop;
+ Append (Buf, Text.all);
- pragma Assert (Colon > 0);
+ -- Postfix warning tag to message if needed
- Txt := new String'(SGR_Error
- & Msg (Msg'First .. Colon)
- & SGR_Reset
- & Msg (Colon + 1 .. Msg'Last));
- end;
- end if;
+ if Tag /= "" and then Warning_Doc_Switch then
+ Append (Buf, ' ' & Tag);
+ end if;
- -- All other cases, add "error: " if unique error tag set
+ -- Postfix [warning-as-error] at the end
- elsif Opt.Unique_Error_Tag then
- Txt := new String'(SGR_Error & "error: " & SGR_Reset & Txt.all);
+ if E_Msg.Warn_Err then
+ Append (Buf, " [warning-as-error]");
end if;
- Output_Text_Within (Txt, Line_Length);
+ Output_Text_Within (To_String (Buf), Line_Length);
end Output_Msg_Text;
---------------------
-- Check style message
- if Msg'Length > 7
- and then Msg (Msg'First .. Msg'First + 6) = "(style)"
+ if Msg'Length > Style_Prefix'Length
+ and then
+ Msg (Msg'First .. Msg'First + Style_Prefix'Length - 1) =
+ Style_Prefix
then
Error_Msg_Kind := Style;
-- Check info message
- elsif Msg'Length > 6
- and then Msg (Msg'First .. Msg'First + 5) = "info: "
+ elsif Msg'Length > Info_Prefix'Length
+ and then
+ Msg (Msg'First .. Msg'First + Info_Prefix'Length - 1) =
+ Info_Prefix
then
Error_Msg_Kind := Info;
-- Check high check message
- elsif Msg'Length > 6
- and then Msg (Msg'First .. Msg'First + 5) = "high: "
+ elsif Msg'Length > High_Prefix'Length
+ and then
+ Msg (Msg'First .. Msg'First + High_Prefix'Length - 1) =
+ High_Prefix
then
Error_Msg_Kind := High_Check;
-- Check medium check message
- elsif Msg'Length > 8
- and then Msg (Msg'First .. Msg'First + 7) = "medium: "
+ elsif Msg'Length > Medium_Prefix'Length
+ and then
+ Msg (Msg'First .. Msg'First + Medium_Prefix'Length - 1) =
+ Medium_Prefix
then
Error_Msg_Kind := Medium_Check;
-- Check low check message
- elsif Msg'Length > 5
- and then Msg (Msg'First .. Msg'First + 4) = "low: "
+ elsif Msg'Length > Low_Prefix'Length
+ and then
+ Msg (Msg'First .. Msg'First + Low_Prefix'Length - 1) =
+ Low_Prefix
then
Error_Msg_Kind := Low_Check;
end if;
-- reporting packages, including Errout and Prj.Err.
with Table;
+with Errsw; use Errsw;
+with Errid; use Errid;
with Types; use Types;
package Erroutc is
-- The following record type and table are used to represent error
-- messages, with one entry in the table being allocated for each message.
+ type Labeled_Span_Id is new Int;
+ No_Labeled_Span : constant Labeled_Span_Id := 0;
+
+ 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.
+
+ Next : Labeled_Span_Id := No_Labeled_Span;
+
+ end record;
+
+ No_Labeled_Span_Object : Labeled_Span_Type := (others => <>);
+
+ package Locations is new Table.Table (
+ Table_Component_Type => Labeled_Span_Type,
+ Table_Index_Type => Labeled_Span_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 200,
+ Table_Increment => 200,
+ Table_Name => "Location");
+
+ type Edit_Id is new Int;
+ No_Edit : constant Edit_Id := 0;
+
+ 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
+
+ Next : Edit_Id := No_Edit;
+ end record;
+
+ package Edits is new Table.Table (
+ Table_Component_Type => Edit_Type,
+ Table_Index_Type => Edit_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 200,
+ Table_Increment => 200,
+ Table_Name => "Edit");
+
+ type Fix_Id is new Int;
+ No_Fix : constant Fix_Id := 0;
+
+ type Fix_Type is record
+ Description : String_Ptr := null;
+ -- Message describing the fix that will be displayed to the user.
+
+ Edits : Edit_Id := No_Edit;
+ -- File changes for the fix.
+
+ Next : Fix_Id := No_Fix;
+ end record;
+
+ package Fixes is new Table.Table (
+ Table_Component_Type => Fix_Type,
+ Table_Index_Type => Fix_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 200,
+ Table_Increment => 200,
+ Table_Name => "Fix");
+
type Error_Msg_Object is record
Text : String_Ptr;
-- Text of error message, fully expanded with all insertions
-- in the circuit for deleting duplicate/redundant error messages.
Kind : Error_Msg_Type;
+ -- The kind of the error message. This determines how the message
+ -- should be handled and what kind of prefix should be added before the
+ -- message text.
+
+ Switch : Switch_Id := No_Switch_Id;
+ -- Identifier for a given switch that enabled the diagnostic
+
+ Id : Diagnostic_Id := No_Diagnostic_Id;
+ -- Unique error code for the given message
+
+ Locations : Labeled_Span_Id := No_Labeled_Span;
+ -- Identifier to the first location identified by the error message.
+ -- These locations are marked with an underlying span line and
+ -- optionally given a short label.
+
+ Fixes : Fix_Id := No_Fix;
+ -- Identifier to the first fix object for the error message. The fix
+ -- contains a suggestion to prevent the error from being triggered.
+ -- This includes edits that can be made to the source code. An edit
+ -- contians a region of the code that needs to be changed and the new
+ -- text that should be inserted to that region.
end record;
package Errors is new Table.Table (
-- as the physically last entry in the error message table, since messages
-- are not always inserted in sequence.
+ procedure Next_Error_Msg (E : in out Error_Msg_Id);
+ -- Update E to point to the next error message in the list of error
+ -- messages. Skip deleted and continuation messages.
+
+ procedure Next_Continuation_Msg (E : in out Error_Msg_Id);
+ -- Update E to point to the next continuation message
+
+ function Kind_To_String (E : Error_Msg_Object) return String is
+ (if E.Warn_Err then "error"
+ else
+ (case E.Kind is
+ when Error | Non_Serious_Error => "error",
+ when Warning => "warning",
+ when Style => "style",
+ when Info => "info",
+ when Low_Check => "low",
+ when Medium_Check => "medium",
+ when High_Check => "high"));
+ -- Returns the name of the error message kind. If it is a warning that has
+ -- been turned to an error then it returns "error".
+
+ function Get_Doc_Switch (E : Error_Msg_Object) return String;
+ -- Returns the documentation switch for a given Error_Msg_Object.
+ --
+ -- This either the name of the switch encased in brackets. E.g [-gnatwx].
+ --
+ -- If the Warn_Char is "* " is then it will return [restriction warning].
+ --
+ -- Otherwise for messages without a switch it will return
+ -- [enabled by default] .
+
+ function Primary_Location (E : Error_Msg_Object) return Labeled_Span_Id;
+ -- Returns the first Primary Labeled_Span associated with the error
+ -- message. Otherwise it returns No_Labeled_Span.
+
+ function Get_Human_Id (E : Error_Msg_Object) return String_Ptr;
+ -- Returns a longer human readable name for the switch associated with the
+ -- error message.
+
+ function Get_Switch (E : Error_Msg_Object) return Switch_Type;
+ -- Returns the Switch information for the given error message
+
+ function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id;
+ -- Returns the Switch information identifier for the given error message
+
+ function Get_Switch_Id
+ (Kind : Error_Msg_Type; Warn_Chr : String) return Switch_Id;
+ -- Returns the Switch information identifier based on the error kind and
+ -- the warning character.
+
--------------------------
-- Warning Mode Control --
--------------------------
function SGR_Locus return String is
(SGR_Seq (Color_Bold));
+ function Get_SGR_Code (E_Msg : Error_Msg_Object) return String is
+ (if E_Msg.Warn_Err then SGR_Error
+ else
+ (case E_Msg.Kind is
+ when Warning | Style => SGR_Warning,
+ when Info => SGR_Note,
+ when others => SGR_Error));
+
-----------------
-- Subprograms --
-----------------
-- splits the line generating multiple lines of output, and in this case
-- the last line has no terminating end of line character.
- procedure Output_Text_Within (Txt : String_Ptr; Line_Length : Nat);
+ procedure Output_Text_Within (Txt : String; Line_Length : Nat);
-- Output the text in Txt, splitting it into lines of at most the size of
-- Line_Length.
-- Note that the call has no effect for continuation messages (those whose
-- first character is '\') except for the Has_Insertion_Line setting.
+ -- Definitions for valid message kind prefixes within error messages.
+
+ Info_Prefix : constant String := "info: ";
+ Low_Prefix : constant String := "low: ";
+ Medium_Prefix : constant String := "medium: ";
+ High_Prefix : constant String := "high: ";
+ Style_Prefix : constant String := "(style) ";
+
procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr);
-- All error messages whose location is in the range From .. To (not
-- including the end points) will be deleted from the error listing.
-- 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
+with JSON_Utils; use JSON_Utils;
+with Output; use Output;
+
+package body Errsw is
Switches : constant array (Switch_Id)
of Switch_Type :=
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 --
-------------------
return No_Switch_Id;
end Get_Switch_Id;
- -------------------
- -- Get_Switch_Id --
- -------------------
-
- function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is
- Switch_Name : constant String :=
- (if E.Warn_Chr = "$ " then "gnatel"
- elsif E.Warn_Chr in "? " | " " then ""
- elsif E.Kind in Erroutc.Warning | Erroutc.Info
- then "gnatw" & E.Warn_Chr
- elsif E.Kind in Erroutc.Style then "gnatw" & E.Warn_Chr
- else "");
- begin
- if Switch_Name /= "" then
- return Get_Switch_Id (Switch_Name);
- else
- return No_Switch_Id;
- end if;
- end Get_Switch_Id;
-
-----------------------------
-- Print_Switch_Repository --
-----------------------------
Write_Eol;
end Print_Switch_Repository;
-end Diagnostics.Switch_Repository;
+end Errsw;
--- /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-2025, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+with Types; use Types;
+
+package Errsw is
+
+ 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;
+
+ 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;
+
+ function Get_Switch (Id : Switch_Id) return Switch_Type;
+
+ function Get_Switch_Id (Name : String) return Switch_Id;
+
+ procedure Print_Switch_Repository;
+
+end Errsw;
with Atree; use Atree;
with Err_Vars; use Err_Vars;
+with Errid; use Errid;
with Erroutc; use Erroutc;
+with Errsw; use Errsw;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
Uncond => Is_Unconditional_Msg,
Msg_Cont => Continuation,
Deleted => False,
- Kind => Error_Msg_Kind));
+ Kind => Error_Msg_Kind,
+ Id => No_Diagnostic_Id,
+ Switch => No_Switch_Id,
+ Locations => No_Labeled_Span,
+ Fixes => No_Fix));
Cur_Msg := Errors.Last;
Prev_Msg := No_Error_Msg;
/* errout: */
-#define Error_Msg_N errout__error_msg_n
-#define Error_Msg_NE errout__error_msg_ne
+#define Error_Msg_N errout__error_msg_n_gigi
+#define Error_Msg_NE errout__error_msg_ne_gigi
#define Set_Identifier_Casing errout__set_identifier_casing
extern void Error_Msg_N (String_Pointer, Node_Id);
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/elists.o \
ada/err_vars.o \
+ ada/errid.o \
ada/errout.o \
ada/erroutc.o \
+ ada/erroutc-pretty_emitter.o \
+ ada/erroutc-sarif_emitter.o \
+ ada/errsw.o \
ada/eval_fat.o \
ada/exp_aggr.o \
ada/exp_spark.o \
ada/impunit.o \
ada/inline.o \
ada/itypes.o \
+ ada/json_utils.o \
ada/krunch.o \
ada/layout.o \
ada/lib-load.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 \
ada/elists.o \
ada/err_vars.o \
+ ada/errid.o \
ada/errout.o \
ada/erroutc.o \
+ ada/erroutc-sarif_emitter.o \
+ ada/erroutc-pretty_emitter.o \
+ ada/errsw.o \
ada/exit.o \
ada/final.o \
ada/fmap.o \
ada/gnatbind.o \
ada/gnatvsn.o \
ada/hostparm.o \
+ ada/json_utils.o \
ada/lib.o \
ada/link.o \
ada/namet.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 \
+ errid.o \
+ errsw.o \
+ erroutc-pretty_emitter.o \
+ erroutc-sarif_emitter.o \
+ json_utils.o
$(EXTRA_GNATMAKE_OBJS)
# Make arch match the current multilib so that the RTS selection code
with Output; use Output;
with System.OS_Lib;
-package body Diagnostics.JSON_Utils is
+package body JSON_Utils is
-----------------
-- Begin_Block --
Write_Char ('"');
end Write_String_Attribute;
-end Diagnostics.JSON_Utils;
+end JSON_Utils;
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+with Types; use Types;
-package Diagnostics.JSON_Utils is
+package JSON_Utils is
JSON_FORMATTING : constant Boolean := True;
-- Adds newlines and indentation to the output JSON.
-- The Value is surrounded by double quotes ("") and the special characters
-- within the string are escaped.
-end Diagnostics.JSON_Utils;
+end JSON_Utils;
-- --
------------------------------------------------------------------------------
+with Errid; use Errid;
with Namet.Sp; use Namet.Sp;
with Stringt; use Stringt;
with Uintp; use Uintp;
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
-with Diagnostics.Constructors; use Diagnostics.Constructors;
separate (Par)
package body Endh is
Wrong_End_Start : Source_Ptr;
Wrong_End_Finish : Source_Ptr;
+
+ Wrong_End_Span : Source_Span;
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
- 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;
+ Wrong_End_Start := 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);
+ while Token /= Tok_Semicolon loop
+ Scan; -- past semicolon
+ end loop;
- else
- Error_Msg_SC -- CODEFIX
- ("`END LOOP;` expected@ for LOOP#!");
- end if;
+ Wrong_End_Finish := Token_Ptr;
+
+ Wrong_End_Span :=
+ To_Span
+ (First => Wrong_End_Start,
+ Ptr => Wrong_End_Start,
+ Last => Wrong_End_Finish);
+
+ Restore_Scan_State (Scan_State);
+
+ Error_Msg -- CODEFIX
+ (Msg => "`END LOOP;` expected@ for LOOP#!",
+ Flag_Span => Wrong_End_Span,
+ N => Empty,
+ Error_Code => GNAT0004,
+ Spans =>
+ (1 => Secondary_Labeled_Span (To_Span (Error_Msg_Sloc))),
+ Fixes =>
+ (1 =>
+ Fix
+ (Description => "Replace with 'end loop;'",
+ Edits =>
+ (1 =>
+ Edit
+ (Text => "end loop;",
+ Span => Wrong_End_Span)))));
else
Error_Msg_SC -- CODEFIX
("`END LOOP &;` expected@!");
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
-with Debug; use Debug;
-with Diagnostics.Constructors; use Diagnostics.Constructors;
with Einfo; use Einfo;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
+with Errid; use Errid;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Tss; use Exp_Tss;
if Present (First (Expressions (N)))
and then Present (First (Component_Associations (N)))
then
- if Debug_Flag_Underscore_DD then
- Record_Mixed_Container_Aggregate_Error
- (Aggr => N,
- Pos_Elem => First (Expressions (N)),
- Named_Elem => First (Component_Associations (N)));
- else
- Error_Msg_N
- ("container aggregate cannot be both positional and named", N);
- end if;
+ Error_Msg_N
+ (Msg =>
+ "container aggregate cannot be both positional and named",
+ N => N,
+ Error_Code => GNAT0006,
+ Spans =>
+ (1 =>
+ Secondary_Labeled_Span
+ (First (Expressions (N)), "positional element "),
+ 2 =>
+ Secondary_Labeled_Span
+ (First (Component_Associations (N)), "named element")));
return;
end if;
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 Elists; use Elists;
+with Errid; use Errid;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Disp; use Exp_Disp;
if not Check_Primitive_Function (Subp, Typ) then
if Present (Ref_Node) then
- 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 local primitive or class-wide function",
- Ref_Node, Subp);
- end if;
+ Error_Msg_N
+ ("improper function for default iterator!",
+ Ref_Node,
+ GNAT0001);
+ Error_Msg_Sloc := Sloc (Subp);
+ Error_Msg_NE
+ ("\\default iterator defined # "
+ & "must be a local primitive or class-wide function",
+ Ref_Node, Subp);
end if;
return False;
-- anyway, no reason to be too strict about this.
if not Relaxed_RM_Semantics then
- 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;
-
+ S := First_Subtype (T);
+ if Present (Freeze_Node (S)) then
+ Error_Msg_N
+ (Msg =>
+ "record representation cannot be specified" &
+ " after the type is frozen",
+ N => N,
+ Error_Code => GNAT0005,
+ Label =>
+ "record representation clause specified here",
+ Spans =>
+ (1 =>
+ Secondary_Labeled_Span
+ (N => Freeze_Node (S),
+ Label =>
+ "Type " & To_Name (S) &
+ " is frozen here"),
+ 2 =>
+ Secondary_Labeled_Span
+ (N => S,
+ Label =>
+ "Type " & To_Name (S) &
+ " is declared here")));
+ Error_Msg_Sloc := Sloc (Freeze_Node (S));
+ Error_Msg_N
+ ("\\move the record representation clause" &
+ " before the freeze point #",
+ N);
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;
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;
with Elists; use Elists;
+with Errid; use Errid;
with Errout; use Errout;
with Exp_Util; use Exp_Util;
with Itypes; use Itypes;
end loop;
if No (Op_Id) then
- 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);
+ Error_Msg_N
+ ("invalid operand types for operator&", N,
+ GNAT0002);
- 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.
- 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);
- end if;
+ elsif Is_Access_Type (Etype (R)) then
+ Error_Msg_N ("\right operand is access type", N);
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 Errid; use Errid;
with Errout; use Errout;
with Exp_Ch9; use Exp_Ch9;
with Elists; use Elists;
-- Pragma case
else
- 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;
+ Error_Msg_Name_1 := Pragma_Name (Prio_Item);
+ Error_Msg_NE
+ (Msg =>
+ "pragma% for & has no effect when Lock_Free given??",
+ N => Prio_Item,
+ E => Id,
+ Error_Code => GNAT0003,
+ Label => "No effect",
+ Spans =>
+ (1 =>
+ Labeled_Span
+ (Span => To_Full_Span (Parent (Id)),
+ Label => "Lock_Free in effect here",
+ Is_Primary => False,
+ Is_Region => True)));
end if;
end if;
end;
projects / thirdparty / gcc.git / commitdiff
