From: Viljar Indus Date: Tue, 17 Sep 2024 12:37:13 +0000 (+0300) Subject: ada: Refactor the implementation of gnat diagnostics X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=9ee9534c60a2e92292b6cea00937a893ef729a18;p=thirdparty%2Fgcc.git ada: Refactor the implementation of gnat diagnostics The goal of this patch is to remove the implementation from the Diagnostic objects and port the new features over to the Error_Msg_Objects. gcc/ada/ChangeLog: * debug.adb: Mark -gnatd_D as unused. * diagnostics-repository.adb: Move to... * errid.adb: ...here. * diagnostics-repository.ads: Move to... * errid.ads: ...here. * errout.adb (Error_Msg_Internal): Add new arguments for the new attributes of Error_Msg_Objects. (Error_Msg): Likewise. (Error_Msg_N): Likewise. (Labeled_Span): New method for creating Labeled_Span-s (Primary_Label_Span): New method for creating primary Labeled_Spans. (Secondary_Labeled_Span): New method for creating secondary Labeled_Spans. (Edit): New method for creating Edit elements. (Fix): New method for creating Fix elements. (Error_Msg_F): Simplify code for evaluating the span. (Error_Msg_FE): Likewise. (Error_Msg_NE): Likewise. (Error_Msg_NEL): Likewise. (Error_Msg_N_Gigi): New method that is used as a wrapper for the Error_Msg_xxx methods that have the new arguments. This function is later mapped to the Error_Msg method used inside gigi. (Error_Msg_NE_Gigi): Likewise. (Write_JSON_Span): Ensure that the Style prefix is included that is removed when parsing the message is reinserted to the JSON report. (Output_Messages): Use the new Pretty_Printer and Sarif_Printer packages to print the messages and remove the old implementation for the pretty printer. (Set_Msg_Text): Remove message kind insertion characters from the final message text to avoid some message kinds being duplicated. (To_Full_Span_First): New method for creating a span for a node. (To_Full_Span): Likewise. * errout.ads: Add the specs for all of the newly added functions. * diagnostics-pretty_emitter.adb: Move to... * erroutc-pretty_emitter.adb: ...here. * diagnostics-pretty_emitter.ads: Move to... * erroutc-pretty_emitter.ads: ...here. * diagnostics-sarif_emitter.adb: Move to... * erroutc-sarif_emitter.adb: ...here. * diagnostics-sarif_emitter.ads: Move to... * erroutc-sarif_emitter.ads: ...here. * erroutc.adb (Next_Error_Msg): New method for iterating to the next error message. (Next_Continuation_Msg): New method for iterating to the next continuation message. (Primary_Location): New method for returning the first primary location for the error message. (Get_Human_Id): New method for returning the human readable name for the switch associated with this error message. (Get_Doc_Switch): New method for creating the tag for the switch used in the error message. (Output_Text_Within): Change the method to operating on Strings instead of String pointers. (Output_Msg_Text): Simplify implementation for generating the error message. (Prescan_Message): Make the String handling more error proof. * erroutc.ads (Error_Msg_Object): Add new attributes that were added to Diagnostic objects to Error_Msg_Objects. Add new methods for handling the new error objects. * diagnostics-switch_repository.adb: Move to... * errsw.adb: ...here. * errutil.adb (Error_Msg): Initialize all of the new attributes added to Error_Msg_Object-s. * fe.h (Error_Msg_N): Update the binding. (Error_Msg_NE): Update the binding. For now the error_msg methods in gigi will use the old simplified interface for those methods. * diagnostics-json_utils.adb: Move to... * json_utils.adb: ...here. * diagnostics-json_utils.ads: Move to... * json_utils.ads: ...here. * par-endh.adb: Replace the old error_msg calls with the updated interface. * sem_aggr.adb: Likewise. * sem_ch13.adb: Likewise. * sem_ch4.adb: Likewise. * sem_ch9.adb: Likewise. * diagnostics-brief_emitter.adb: Removed. * diagnostics-brief_emitter.ads: Removed. * diagnostics-constructors.adb: Removed. * diagnostics-constructors.ads: Removed. * diagnostics-converter.adb: Removed. * diagnostics-converter.ads: Removed. * diagnostics-switch_repository.ads: Removed. * diagnostics-utils.adb: Removed. * diagnostics-utils.ads: Removed. * diagnostics.adb: Removed. * diagnostics.ads: Removed. * errsw.ads: New file. Based on diagnostics-switch_repository.ads. It additionally contains all the switch enumerations. * gcc-interface/Make-lang.in: Update compilation dependencies. * gcc-interface/Makefile.in: Likewise. --- diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index ac3ce41dcc51..3a39ec89c40f 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -168,7 +168,7 @@ package body Debug is -- 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 diff --git a/gcc/ada/diagnostics-brief_emitter.adb b/gcc/ada/diagnostics-brief_emitter.adb deleted file mode 100644 index 0315b53c402e..000000000000 --- a/gcc/ada/diagnostics-brief_emitter.adb +++ /dev/null @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/diagnostics-brief_emitter.ads b/gcc/ada/diagnostics-brief_emitter.ads deleted file mode 100644 index 706293e48ddb..000000000000 --- a/gcc/ada/diagnostics-brief_emitter.ads +++ /dev/null @@ -1,28 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/diagnostics-constructors.adb b/gcc/ada/diagnostics-constructors.adb deleted file mode 100644 index 0bc8750496d5..000000000000 --- a/gcc/ada/diagnostics-constructors.adb +++ /dev/null @@ -1,514 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/diagnostics-constructors.ads b/gcc/ada/diagnostics-constructors.ads deleted file mode 100644 index a568f0f879f8..000000000000 --- a/gcc/ada/diagnostics-constructors.ads +++ /dev/null @@ -1,143 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/diagnostics-converter.adb b/gcc/ada/diagnostics-converter.adb deleted file mode 100644 index b3d9edfffec6..000000000000 --- a/gcc/ada/diagnostics-converter.adb +++ /dev/null @@ -1,254 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/diagnostics-converter.ads b/gcc/ada/diagnostics-converter.ads deleted file mode 100644 index a3b15797a94b..000000000000 --- a/gcc/ada/diagnostics-converter.ads +++ /dev/null @@ -1,31 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/diagnostics-switch_repository.ads b/gcc/ada/diagnostics-switch_repository.ads deleted file mode 100644 index afc4d1f879d6..000000000000 --- a/gcc/ada/diagnostics-switch_repository.ads +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/diagnostics-utils.adb b/gcc/ada/diagnostics-utils.adb deleted file mode 100644 index abde955f8e8e..000000000000 --- a/gcc/ada/diagnostics-utils.adb +++ /dev/null @@ -1,357 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- D I A G N O S T I C S . U T I L S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2025, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Diagnostics.Repository; use Diagnostics.Repository; -with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; -with Errout; use Errout; -with Erroutc; use Erroutc; -with Namet; use Namet; -with Opt; use Opt; -with Sinput; use Sinput; -with Sinfo.Nodes; use Sinfo.Nodes; -with Warnsw; use Warnsw; - -package body Diagnostics.Utils is - - ------------------ - -- Get_Human_Id -- - ------------------ - - function Get_Human_Id (D : Diagnostic_Type) return String_Ptr is - begin - if D.Switch = No_Switch_Id then - return Diagnostic_Entries (D.Id).Human_Id; - else - return Get_Switch (D).Human_Id; - end if; - end Get_Human_Id; - - ------------------ - -- To_File_Name -- - ------------------ - - function To_File_Name (Sptr : Source_Ptr) return String is - Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr); - Ref_Name : constant File_Name_Type := - (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile) - else Reference_Name (Sfile)); - - begin - return Get_Name_String (Ref_Name); - end To_File_Name; - - -------------------- - -- Line_To_String -- - -------------------- - - function Line_To_String (Sptr : Source_Ptr) return String is - Line : constant Logical_Line_Number := Get_Logical_Line_Number (Sptr); - Img_Raw : constant String := Int'Image (Int (Line)); - - begin - return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); - end Line_To_String; - - ---------------------- - -- Column_To_String -- - ---------------------- - - function Column_To_String (Sptr : Source_Ptr) return String is - Col : constant Column_Number := Get_Column_Number (Sptr); - Img_Raw : constant String := Int'Image (Int (Col)); - - begin - return - (if Col < 10 then "0" else "") - & Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); - end Column_To_String; - - --------------- - -- To_String -- - --------------- - - function To_String (Sptr : Source_Ptr) return String is - begin - return - To_File_Name (Sptr) & ":" & Line_To_String (Sptr) & ":" - & Column_To_String (Sptr); - end To_String; - - -------------------- - -- Sloc_To_String -- - -------------------- - - function Sloc_To_String - (N : Node_Or_Entity_Id; Ref : Source_Ptr) return String - is - - begin - return Sloc_To_String (Sloc (N), Ref); - end Sloc_To_String; - - -------------------- - -- Sloc_To_String -- - -------------------- - - function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String - is - - begin - if Sptr = No_Location then - return "at unknown location"; - - elsif Sptr = System_Location then - return "in package System"; - - elsif Sptr = Standard_Location then - return "in package Standard"; - - elsif Sptr = Standard_ASCII_Location then - return "in package Standard.ASCII"; - - else - if Full_File_Name (Get_Source_File_Index (Sptr)) - /= Full_File_Name (Get_Source_File_Index (Ref)) - then - return "at " & To_String (Sptr); - else - return "at line " & Line_To_String (Sptr); - end if; - end if; - end Sloc_To_String; - - ------------------ - -- To_Full_Span -- - ------------------ - - function To_Full_Span (N : Node_Id) return Source_Span - is - Fst, Lst : Node_Id; - begin - First_And_Last_Nodes (N, Fst, Lst); - return To_Span (Ptr => Sloc (N), - First => First_Sloc (Fst), - Last => Last_Sloc (Lst)); - end To_Full_Span; - - --------------- - -- To_String -- - --------------- - - function To_String (Id : Diagnostic_Id) return String is - begin - if Id = No_Diagnostic_Id then - return "GNAT0000"; - else - return Id'Img; - end if; - end To_String; - - ------------- - -- To_Name -- - ------------- - - function To_Name (E : Entity_Id) return String is - begin - -- The name of the node operator "&" has many special cases. Reuse the - -- node to name conversion implementation from the errout package for - -- now. - - Error_Msg_Node_1 := E; - Set_Msg_Text ("&", Sloc (E)); - - return Msg_Buffer (1 .. Msglen); - end To_Name; - - ------------------ - -- To_Type_Name -- - ------------------ - - function To_Type_Name (E : Entity_Id) return String is - begin - Error_Msg_Node_1 := E; - Set_Msg_Text ("}", Sloc (E)); - - return Msg_Buffer (1 .. Msglen); - end To_Type_Name; - - -------------------- - -- Kind_To_String -- - -------------------- - - function Kind_To_String - (D : Sub_Diagnostic_Type; - Parent : Diagnostic_Type) return String - is - (case D.Kind is - when Continuation => Kind_To_String (Parent), - when Help => "help", - when Note => "note", - when Suggestion => "suggestion"); - - -------------------- - -- Kind_To_String -- - -------------------- - - function Kind_To_String (D : Diagnostic_Type) return String is - (if D.Warn_Err then "error" - else - (case D.Kind is - when Diagnostics.Error | Non_Serious_Error => "error", - when Warning | Restriction_Warning | Default_Warning | - Tagless_Warning => "warning", - when Style => "style", - when Info => "info")); - - ------------------------------ - -- Get_Primary_Labeled_Span -- - ------------------------------ - - function Get_Primary_Labeled_Span (Spans : Labeled_Span_List) - return Labeled_Span_Type - is - use Labeled_Span_Lists; - - S : Labeled_Span_Type; - It : Iterator; - begin - if Present (Spans) then - It := Iterate (Spans); - while Has_Next (It) loop - Next (It, S); - if S.Is_Primary then - return S; - end if; - end loop; - end if; - - return No_Labeled_Span; - end Get_Primary_Labeled_Span; - - -------------------- - -- Get_Doc_Switch -- - -------------------- - - function Get_Doc_Switch (Diag : Diagnostic_Type) return String is - begin - if Warning_Doc_Switch - and then Diag.Kind in Default_Warning - | Info - | Restriction_Warning - | Style - | Warning - then - if Diag.Switch = No_Switch_Id then - if Diag.Kind = Restriction_Warning then - return "[restriction warning]"; - - -- Info messages can have a switch tag but they should not have - -- a default switch tag. - - elsif Diag.Kind /= Info then - - -- For Default_Warning - - return "[enabled by default]"; - end if; - else - declare - S : constant Switch_Type := Get_Switch (Diag); - begin - return "[-" & S.Short_Name.all & "]"; - end; - end if; - end if; - - return ""; - end Get_Doc_Switch; - - -------------------- - -- Appears_Before -- - -------------------- - - function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean is - - begin - return Appears_Before (Primary_Location (D1).Span.Ptr, - Primary_Location (D2).Span.Ptr); - end Appears_Before; - - -------------------- - -- Appears_Before -- - -------------------- - - function Appears_Before (P1, P2 : Source_Ptr) return Boolean is - - begin - if Get_Source_File_Index (P1) = Get_Source_File_Index (P2) then - if Get_Logical_Line_Number (P1) = Get_Logical_Line_Number (P2) then - return Get_Column_Number (P1) < Get_Column_Number (P2); - else - return Get_Logical_Line_Number (P1) < Get_Logical_Line_Number (P2); - end if; - else - return Get_Source_File_Index (P1) < Get_Source_File_Index (P2); - end if; - end Appears_Before; - - ------------------------------ - -- Insert_Based_On_Location -- - ------------------------------ - - procedure Insert_Based_On_Location - (List : Diagnostic_List; - Diagnostic : Diagnostic_Type) - is - use Diagnostics_Lists; - - It : Iterator := Iterate (List); - D : Diagnostic_Type; - begin - -- This is the common scenario where the error is reported at the - -- natural order the tree is processed. This saves a lot of time when - -- looking for the correct position in the list when there are a lot of - -- diagnostics. - - if Present (List) and then - not Is_Empty (List) and then - Appears_Before (Last (List), Diagnostic) - then - Append (List, Diagnostic); - else - while Has_Next (It) loop - Next (It, D); - - if Appears_Before (Diagnostic, D) then - Insert_Before (List, D, Diagnostic); - return; - end if; - end loop; - - Append (List, Diagnostic); - end if; - end Insert_Based_On_Location; - -end Diagnostics.Utils; diff --git a/gcc/ada/diagnostics-utils.ads b/gcc/ada/diagnostics-utils.ads deleted file mode 100644 index 33cd67fc5385..000000000000 --- a/gcc/ada/diagnostics-utils.ads +++ /dev/null @@ -1,91 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 ". 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 ". - -- * Otherwise sloc yields "at ::" - - function Sloc_To_String (N : Node_Or_Entity_Id; - Ref : Source_Ptr) - return String; - -- Converts the Sloc of the node or entity to a Sloc string. - - function To_String (Sptr : Source_Ptr) return String; - -- Convert the source pointer to a string of the form: "file:line:column" - - function To_File_Name (Sptr : Source_Ptr) return String; - -- Converts the file name of the Sptr to a string. - - function Line_To_String (Sptr : Source_Ptr) return String; - -- Converts the logical line number of the Sptr to a string. - - function Column_To_String (Sptr : Source_Ptr) return String; - -- Converts the column number of the Sptr to a string. Column values less - -- than 10 are prefixed with a 0. - - function To_Full_Span (N : Node_Id) return Source_Span; - - function To_String (Id : Diagnostic_Id) return String; - -- Convert the diagnostic ID to a 4 character string padded with 0-s. - - function To_Name (E : Entity_Id) return String; - - function To_Type_Name (E : Entity_Id) return String; - - function Kind_To_String (D : Diagnostic_Type) return String; - - function Kind_To_String - (D : Sub_Diagnostic_Type; - Parent : Diagnostic_Type) return String; - - function Get_Primary_Labeled_Span (Spans : Labeled_Span_List) - return Labeled_Span_Type; - - function Get_Doc_Switch (Diag : Diagnostic_Type) return String; - - function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean; - - function Appears_Before (P1, P2 : Source_Ptr) return Boolean; - - procedure Insert_Based_On_Location - (List : Diagnostic_List; - Diagnostic : Diagnostic_Type); - -end Diagnostics.Utils; diff --git a/gcc/ada/diagnostics.adb b/gcc/ada/diagnostics.adb deleted file mode 100644 index c98eda2264a9..000000000000 --- a/gcc/ada/diagnostics.adb +++ /dev/null @@ -1,539 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/diagnostics.ads b/gcc/ada/diagnostics.ads deleted file mode 100644 index 67a8c20bd676..000000000000 --- a/gcc/ada/diagnostics.ads +++ /dev/null @@ -1,477 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/diagnostics-repository.adb b/gcc/ada/errid.adb similarity index 92% rename from gcc/ada/diagnostics-repository.adb rename to gcc/ada/errid.adb index f01a2df6f9b5..a661fcf1e0be 100644 --- a/gcc/ada/diagnostics-repository.adb +++ b/gcc/ada/errid.adb @@ -22,12 +22,23 @@ -- 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 -- @@ -119,4 +130,4 @@ package body Diagnostics.Repository is Write_Eol; end Print_Diagnostic_Repository; -end Diagnostics.Repository; +end Errid; diff --git a/gcc/ada/diagnostics-repository.ads b/gcc/ada/errid.ads similarity index 75% rename from gcc/ada/diagnostics-repository.ads rename to gcc/ada/errid.ads index 778c99126be6..21ef79c14017 100644 --- a/gcc/ada/diagnostics-repository.ads +++ b/gcc/ada/errid.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -22,7 +22,40 @@ -- 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; @@ -51,58 +84,28 @@ package Diagnostics.Repository is 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"), @@ -110,4 +113,4 @@ package Diagnostics.Repository is procedure Print_Diagnostic_Repository; -end Diagnostics.Repository; +end Errid; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 23c6b8855fd4..25d1d52e34b4 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -33,15 +33,18 @@ with Atree; use Atree; with Casing; use Casing; with Csets; use Csets; with Debug; use Debug; -with Diagnostics.Converter; use Diagnostics.Converter; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; 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; @@ -97,10 +100,14 @@ package body Errout is ----------------------- 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 @@ -285,6 +292,115 @@ package body Errout is 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 -- --------------- @@ -328,9 +444,13 @@ package body Errout is 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; @@ -459,7 +579,15 @@ package body Errout is -- 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; @@ -626,10 +754,14 @@ package body Errout is -- 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; @@ -715,7 +847,7 @@ package body Errout is -- 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 @@ -728,10 +860,10 @@ package body Errout is 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; @@ -749,10 +881,11 @@ package body Errout is -- 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; @@ -785,8 +918,8 @@ package body Errout is -- 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); @@ -842,13 +975,8 @@ package body Errout is ----------------- 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; ------------------ @@ -860,13 +988,8 @@ package body Errout is 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; ------------------------------ @@ -918,10 +1041,14 @@ package body Errout is ------------------------ 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; @@ -937,6 +1064,12 @@ package body Errout is 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 @@ -1156,11 +1289,15 @@ package body Errout is -- 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; @@ -1226,6 +1363,37 @@ package body Errout is 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 @@ -1245,7 +1413,12 @@ package body Errout is 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 @@ -1416,33 +1589,72 @@ package body Errout is -- 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 -- @@ -1465,10 +1677,14 @@ package body Errout is 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 @@ -1502,7 +1718,14 @@ package body Errout is 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; @@ -1522,17 +1745,12 @@ package body Errout is 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; @@ -2457,9 +2675,13 @@ package body Errout is 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 (""""); @@ -2502,109 +2724,21 @@ package body Errout is 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; @@ -2664,310 +2798,18 @@ package body Errout is 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 @@ -3039,15 +2881,72 @@ package body Errout is -- 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 @@ -4056,17 +3955,45 @@ package body Errout is 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 @@ -4109,14 +4036,6 @@ package body Errout is 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; @@ -4372,6 +4291,48 @@ package body Errout is 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 -- -------------------------- diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 24cc1c233a92..98aa4b4c1209 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -30,6 +30,7 @@ with Err_Vars; with Erroutc; +with Errid; use Errid; with Namet; use Namet; with Table; with Types; use Types; @@ -580,6 +581,19 @@ package Errout is -- 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. @@ -713,11 +727,24 @@ package Errout is 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; @@ -753,7 +780,13 @@ package Errout is -- 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 @@ -762,6 +795,9 @@ package Errout is -- 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); @@ -771,15 +807,23 @@ package Errout is -- 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 @@ -795,10 +839,14 @@ package Errout is 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). @@ -827,6 +875,16 @@ package Errout is -- 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 @@ -966,6 +1024,32 @@ package Errout is 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 -- ------------------------------------ @@ -1028,4 +1112,8 @@ package Errout is -- 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; diff --git a/gcc/ada/diagnostics-pretty_emitter.adb b/gcc/ada/erroutc-pretty_emitter.adb similarity index 58% rename from gcc/ada/diagnostics-pretty_emitter.adb rename to gcc/ada/erroutc-pretty_emitter.adb index 6d3b90827301..86e2e3ddec6d 100644 --- a/gcc/ada/diagnostics-pretty_emitter.adb +++ b/gcc/ada/erroutc-pretty_emitter.adb @@ -23,12 +23,13 @@ -- -- ------------------------------------------------------------------------------ -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 @@ -46,17 +47,35 @@ package body Diagnostics.Pretty_Emitter is 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; @@ -75,9 +94,14 @@ package body Diagnostics.Pretty_Emitter is 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; @@ -86,9 +110,7 @@ package body Diagnostics.Pretty_Emitter is 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, @@ -98,8 +120,8 @@ package body Diagnostics.Pretty_Emitter is 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. -- @@ -107,36 +129,31 @@ package body Diagnostics.Pretty_Emitter is -- 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. : @@ -144,33 +161,62 @@ package body Diagnostics.Pretty_Emitter is -- 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. + -- + -- --> + -- + + 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 @@ -187,40 +233,50 @@ package body Diagnostics.Pretty_Emitter is -- 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: -- -- '['']' : ['['']'] - 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 @@ -229,39 +285,55 @@ package body Diagnostics.Pretty_Emitter is -- 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: + -- + -- --> + -- - + -- + + + procedure Print_Fix (Fix : Fix_Type; Offset : Integer); + -- Prints a fix object as follows + -- + -- + 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); + + 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; ------------------ @@ -273,9 +345,7 @@ package body Diagnostics.Pretty_Emitter is 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; @@ -291,9 +361,7 @@ package body Diagnostics.Pretty_Emitter is 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; @@ -309,9 +377,7 @@ package body Diagnostics.Pretty_Emitter is 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; @@ -347,7 +413,7 @@ package body Diagnostics.Pretty_Emitter is 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; @@ -360,11 +426,10 @@ package body Diagnostics.Pretty_Emitter is -- 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 @@ -378,64 +443,34 @@ package body Diagnostics.Pretty_Emitter is 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 @@ -447,20 +482,14 @@ package body Diagnostics.Pretty_Emitter is -- 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; @@ -476,10 +505,7 @@ package body Diagnostics.Pretty_Emitter is -- 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 (" |"); @@ -511,23 +537,27 @@ package body Diagnostics.Pretty_Emitter is -- 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; @@ -535,11 +565,13 @@ package body Diagnostics.Pretty_Emitter is -- 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; @@ -562,8 +594,8 @@ package body Diagnostics.Pretty_Emitter is 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; @@ -590,16 +622,14 @@ package body Diagnostics.Pretty_Emitter is --------------------------- 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), @@ -620,9 +650,7 @@ package body Diagnostics.Pretty_Emitter is 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; @@ -630,13 +658,10 @@ package body Diagnostics.Pretty_Emitter is 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; @@ -652,15 +677,15 @@ package body Diagnostics.Pretty_Emitter is -- 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); @@ -675,6 +700,7 @@ package body Diagnostics.Pretty_Emitter is File_Section_Lists.Append (Sections, (File => new String'(To_File_Name (Loc.Span.Ptr)), + Ptr => Loc.Span.Ptr, Lines => Lines)); end Create_File_Section; @@ -683,11 +709,10 @@ package body Diagnostics.Pretty_Emitter is -------------------------- 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; @@ -696,8 +721,8 @@ package body Diagnostics.Pretty_Emitter is 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); @@ -711,16 +736,20 @@ package body Diagnostics.Pretty_Emitter is 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; @@ -730,21 +759,24 @@ package body Diagnostics.Pretty_Emitter is -- 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; @@ -775,8 +807,7 @@ package body Diagnostics.Pretty_Emitter is (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 @@ -784,13 +815,15 @@ package body Diagnostics.Pretty_Emitter is 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); @@ -798,6 +831,8 @@ package body Diagnostics.Pretty_Emitter is 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. @@ -808,24 +843,27 @@ package body Diagnostics.Pretty_Emitter is 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; ------------------- @@ -833,7 +871,7 @@ package body Diagnostics.Pretty_Emitter is ------------------- 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; @@ -843,22 +881,24 @@ package body Diagnostics.Pretty_Emitter is ------------------------------- 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; @@ -867,18 +907,18 @@ package body Diagnostics.Pretty_Emitter is -- 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; @@ -896,45 +936,62 @@ package body Diagnostics.Pretty_Emitter is -- 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; @@ -950,28 +1007,23 @@ package body Diagnostics.Pretty_Emitter is -- 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. @@ -980,17 +1032,23 @@ package body Diagnostics.Pretty_Emitter is 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; @@ -1003,18 +1061,21 @@ package body Diagnostics.Pretty_Emitter is 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 := @@ -1024,7 +1085,11 @@ package body Diagnostics.Pretty_Emitter is 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); @@ -1034,32 +1099,28 @@ package body Diagnostics.Pretty_Emitter is -- 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; @@ -1070,44 +1131,49 @@ package body Diagnostics.Pretty_Emitter is -- 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; @@ -1116,16 +1182,16 @@ package body Diagnostics.Pretty_Emitter is -- 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; ---------------- @@ -1134,7 +1200,7 @@ package body Diagnostics.Pretty_Emitter is 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)); @@ -1150,10 +1216,7 @@ package body Diagnostics.Pretty_Emitter is 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 @@ -1161,19 +1224,13 @@ package body Diagnostics.Pretty_Emitter is 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; --------------- @@ -1181,7 +1238,7 @@ package body Diagnostics.Pretty_Emitter is --------------- procedure Print_Fix (Fix : Fix_Type; Offset : Integer) is - use Edit_Lists; + E : Edit_Id; begin Write_Str (String'(1 .. Offset => ' ')); Write_Str ("+ Fix: "); @@ -1191,19 +1248,12 @@ package body Diagnostics.Pretty_Emitter is 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; -------------------------- @@ -1211,26 +1261,23 @@ package body Diagnostics.Pretty_Emitter is -------------------------- 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; @@ -1238,57 +1285,126 @@ package body Diagnostics.Pretty_Emitter is -- 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; diff --git a/gcc/ada/diagnostics-pretty_emitter.ads b/gcc/ada/erroutc-pretty_emitter.ads similarity index 93% rename from gcc/ada/diagnostics-pretty_emitter.ads rename to gcc/ada/erroutc-pretty_emitter.ads index 2f5ba042aaa6..3ff0109db639 100644 --- a/gcc/ada/diagnostics-pretty_emitter.ads +++ b/gcc/ada/erroutc-pretty_emitter.ads @@ -23,6 +23,6 @@ -- -- ------------------------------------------------------------------------------ -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; diff --git a/gcc/ada/diagnostics-sarif_emitter.adb b/gcc/ada/erroutc-sarif_emitter.adb similarity index 76% rename from gcc/ada/diagnostics-sarif_emitter.adb rename to gcc/ada/erroutc-sarif_emitter.adb index d7f923437012..791becb39657 100644 --- a/gcc/ada/diagnostics-sarif_emitter.adb +++ b/gcc/ada/erroutc-sarif_emitter.adb @@ -23,18 +23,17 @@ -- -- ------------------------------------------------------------------------------ -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 @@ -77,7 +76,7 @@ package body Diagnostics.SARIF_Emitter is 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"); @@ -90,15 +89,44 @@ package body Diagnostics.SARIF_Emitter is -- 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 @@ -116,7 +144,7 @@ package body Diagnostics.SARIF_Emitter 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); @@ -135,7 +163,7 @@ package body Diagnostics.SARIF_Emitter is -- artifactChanges: [] -- } - procedure Print_Fixes (Diag : Diagnostic_Type); + procedure Print_Fixes (E_Msg : Error_Msg_Object); -- Print the fixes node -- -- "fixes": [ @@ -172,8 +200,7 @@ package body Diagnostics.SARIF_Emitter is -- "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 @@ -197,7 +224,7 @@ package body Diagnostics.SARIF_Emitter is -- } -- } - 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. -- @@ -224,7 +251,7 @@ package body Diagnostics.SARIF_Emitter is -- } -- }, - 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. @@ -233,11 +260,12 @@ package body Diagnostics.SARIF_Emitter is -- -- ], - 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 @@ -265,7 +293,7 @@ package body Diagnostics.SARIF_Emitter is -- 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": , -- "level": , @@ -276,7 +304,7 @@ package body Diagnostics.SARIF_Emitter is -- "relatedLocations": [] -- }, - procedure Print_Results (Diags : Diagnostic_List); + procedure Print_Results; -- Print a results node that consists of multiple result nodes for each -- diagnostic instance. -- @@ -284,7 +312,7 @@ package body Diagnostics.SARIF_Emitter is -- -- ] - 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 @@ -294,7 +322,7 @@ package body Diagnostics.SARIF_Emitter is -- "name": -- }, - 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. @@ -303,7 +331,7 @@ package body Diagnostics.SARIF_Emitter is -- -- ] - 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 @@ -314,7 +342,7 @@ package body Diagnostics.SARIF_Emitter is -- "results": [] -- } - procedure Print_Tool (Diags : Diagnostic_List); + procedure Print_Tool; -- Print a tool node that consists of -- * a driver node that consists of: -- * name @@ -329,6 +357,15 @@ package body Diagnostics.SARIF_Emitter is -- } -- } + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Artifact_Change) is + begin + Edit_Lists.Destroy (Elem.Replacements); + end Destroy; + -------------------------- -- Get_Artifact_Changes -- -------------------------- @@ -341,8 +378,7 @@ package body Diagnostics.SARIF_Emitter is -- 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 := @@ -363,7 +399,7 @@ package body Diagnostics.SARIF_Emitter is 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; @@ -372,12 +408,19 @@ package body Diagnostics.SARIF_Emitter is 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; @@ -387,46 +430,46 @@ package body Diagnostics.SARIF_Emitter is -- 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; @@ -435,10 +478,9 @@ package body Diagnostics.SARIF_Emitter is -- 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; @@ -511,19 +553,15 @@ package body Diagnostics.SARIF_Emitter is 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 @@ -564,11 +602,12 @@ package body Diagnostics.SARIF_Emitter is -- 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 (','); @@ -608,7 +647,7 @@ package body Diagnostics.SARIF_Emitter is 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; @@ -643,31 +682,30 @@ package body Diagnostics.SARIF_Emitter is -- 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; @@ -736,11 +774,12 @@ package body Diagnostics.SARIF_Emitter is -- 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 @@ -774,9 +813,7 @@ package body Diagnostics.SARIF_Emitter is -- 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; @@ -815,10 +852,11 @@ package body Diagnostics.SARIF_Emitter is -- 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; @@ -833,18 +871,18 @@ package body Diagnostics.SARIF_Emitter is -- 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 @@ -859,12 +897,13 @@ package body Diagnostics.SARIF_Emitter is 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; ------------------- @@ -912,13 +951,12 @@ package body Diagnostics.SARIF_Emitter is -- 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 @@ -927,8 +965,9 @@ package body Diagnostics.SARIF_Emitter is -- 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 @@ -942,78 +981,64 @@ package body Diagnostics.SARIF_Emitter is 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 ('{'); @@ -1022,42 +1047,42 @@ package body Diagnostics.SARIF_Emitter is -- 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; @@ -1069,32 +1094,28 @@ package body Diagnostics.SARIF_Emitter is -- 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; @@ -1105,14 +1126,14 @@ package body Diagnostics.SARIF_Emitter is -- 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; @@ -1131,13 +1152,11 @@ package body Diagnostics.SARIF_Emitter is -- 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 @@ -1161,13 +1180,14 @@ package body Diagnostics.SARIF_Emitter is 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 & """" & ": " & "{"); @@ -1190,7 +1210,7 @@ package body Diagnostics.SARIF_Emitter is Write_Char (','); NL_And_Indent; - Print_Rules (Diags); + Print_Rules; -- End of tool.driver @@ -1211,7 +1231,7 @@ package body Diagnostics.SARIF_Emitter is -- Print_Runs -- ---------------- - procedure Print_Runs (Diags : Diagnostic_List) is + procedure Print_Runs is begin Write_Str ("""" & N_RUNS & """" & ": " & "["); @@ -1227,7 +1247,7 @@ package body Diagnostics.SARIF_Emitter is -- A run consists of a tool - Print_Tool (Diags); + Print_Tool; Write_Char (','); NL_And_Indent; @@ -1244,7 +1264,7 @@ package body Diagnostics.SARIF_Emitter is -- A run consists of results - Print_Results (Diags); + Print_Results; -- End of run @@ -1265,7 +1285,7 @@ package body Diagnostics.SARIF_Emitter is -- Print_SARIF_Report -- ------------------------ - procedure Print_SARIF_Report (Diags : Diagnostic_List) is + procedure Print_SARIF_Report is begin Write_Char ('{'); Begin_Block; @@ -1279,7 +1299,7 @@ package body Diagnostics.SARIF_Emitter is Write_Char (','); NL_And_Indent; - Print_Runs (Diags); + Print_Runs; End_Block; NL_And_Indent; @@ -1288,4 +1308,4 @@ package body Diagnostics.SARIF_Emitter is Write_Eol; end Print_SARIF_Report; -end Diagnostics.SARIF_Emitter; +end Erroutc.SARIF_Emitter; diff --git a/gcc/ada/diagnostics-sarif_emitter.ads b/gcc/ada/erroutc-sarif_emitter.ads similarity index 93% rename from gcc/ada/diagnostics-sarif_emitter.ads rename to gcc/ada/erroutc-sarif_emitter.ads index 4c8ec785b4e6..9272b545462f 100644 --- a/gcc/ada/diagnostics-sarif_emitter.ads +++ b/gcc/ada/erroutc-sarif_emitter.ads @@ -23,7 +23,7 @@ -- -- ------------------------------------------------------------------------------ -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; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index c8de60d2a5d8..76113b9e05ac 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -491,6 +491,134 @@ package body Erroutc is 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 -- ------------- @@ -752,7 +880,7 @@ package body Erroutc is -- 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 @@ -869,98 +997,62 @@ package body Erroutc is 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; --------------------- @@ -1056,36 +1148,46 @@ package body Erroutc is -- 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; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 3f080a557ec9..5ee26797c72b 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -27,6 +27,8 @@ -- reporting packages, including Errout and Prj.Err. with Table; +with Errsw; use Errsw; +with Errid; use Errid; with Types; use Types; package Erroutc is @@ -177,6 +179,84 @@ 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 @@ -248,6 +328,27 @@ package Erroutc is -- 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 ( @@ -268,6 +369,56 @@ package Erroutc is -- 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 -- -------------------------- @@ -422,6 +573,14 @@ package Erroutc is 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 -- ----------------- @@ -513,7 +672,7 @@ package Erroutc is -- 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. @@ -549,6 +708,14 @@ package Erroutc is -- 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. diff --git a/gcc/ada/diagnostics-switch_repository.adb b/gcc/ada/errsw.adb similarity index 96% rename from gcc/ada/diagnostics-switch_repository.adb rename to gcc/ada/errsw.adb index 1627de36097d..f4c4128fa3f2 100644 --- a/gcc/ada/diagnostics-switch_repository.adb +++ b/gcc/ada/errsw.adb @@ -22,9 +22,10 @@ -- 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 := @@ -553,12 +554,6 @@ package body Diagnostics.Switch_Repository is 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 -- ------------------- @@ -577,26 +572,6 @@ package body Diagnostics.Switch_Repository is 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 -- ----------------------------- @@ -687,4 +662,4 @@ package body Diagnostics.Switch_Repository is Write_Eol; end Print_Switch_Repository; -end Diagnostics.Switch_Repository; +end Errsw; diff --git a/gcc/ada/errsw.ads b/gcc/ada/errsw.ads new file mode 100644 index 000000000000..b6d01304c1ae --- /dev/null +++ b/gcc/ada/errsw.ads @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index 5548d533e79e..b5fd1a525dbf 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -25,7 +25,9 @@ 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; @@ -211,7 +213,11 @@ package body Errutil is 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; diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index bb8b96e9cb5a..0b80a56cf195 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -110,8 +110,8 @@ extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, unsigned char); /* 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); diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 98074b77a428..54496ea75a6b 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -315,23 +315,17 @@ GNAT_ADA_OBJS = \ ada/cstand.o \ ada/debug.o \ ada/debug_a.o \ - ada/diagnostics-brief_emitter.o \ - ada/diagnostics-constructors.o \ - ada/diagnostics-converter.o \ - ada/diagnostics-json_utils.o \ - ada/diagnostics-pretty_emitter.o \ - ada/diagnostics-repository.o \ - ada/diagnostics-sarif_emitter.o \ - ada/diagnostics-switch_repository.o \ - ada/diagnostics-utils.o \ - ada/diagnostics.o \ ada/einfo-entities.o \ ada/einfo-utils.o \ ada/einfo.o \ 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 \ @@ -380,6 +374,7 @@ GNAT_ADA_OBJS = \ ada/impunit.o \ ada/inline.o \ ada/itypes.o \ + ada/json_utils.o \ ada/krunch.o \ ada/layout.o \ ada/lib-load.o \ @@ -610,23 +605,17 @@ GNATBIND_OBJS = \ ada/casing.o \ ada/csets.o \ ada/debug.o \ - ada/diagnostics-brief_emitter.o \ - ada/diagnostics-constructors.o \ - ada/diagnostics-converter.o \ - ada/diagnostics-json_utils.o \ - ada/diagnostics-pretty_emitter.o \ - ada/diagnostics-repository.o \ - ada/diagnostics-sarif_emitter.o \ - ada/diagnostics-switch_repository.o \ - ada/diagnostics-utils.o \ - ada/diagnostics.o \ ada/einfo-entities.o \ ada/einfo-utils.o \ ada/einfo.o \ 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 \ @@ -634,6 +623,7 @@ GNATBIND_OBJS = \ ada/gnatbind.o \ ada/gnatvsn.o \ ada/hostparm.o \ + ada/json_utils.o \ ada/lib.o \ ada/link.o \ ada/namet.o \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 2c42cb1afb48..a8777e1dc796 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -328,16 +328,11 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \ switch.o switch-m.o table.o targparm.o tempdir.o types.o uintp.o \ uname.o urealp.o usage.o widechar.o warnsw.o \ seinfo.o einfo-entities.o einfo-utils.o sinfo-nodes.o sinfo-utils.o \ - diagnostics-brief_emitter.o \ - diagnostics-constructors.o \ - diagnostics-converter.o \ - diagnostics-json_utils.o \ - diagnostics-pretty_emitter.o \ - diagnostics-repository.o \ - diagnostics-sarif_emitter.o \ - diagnostics-switch_repository.o \ - diagnostics-utils.o \ - diagnostics.o \ + 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 diff --git a/gcc/ada/diagnostics-json_utils.adb b/gcc/ada/json_utils.adb similarity index 99% rename from gcc/ada/diagnostics-json_utils.adb rename to gcc/ada/json_utils.adb index 8ce04c4631f6..61b0693b5352 100644 --- a/gcc/ada/diagnostics-json_utils.adb +++ b/gcc/ada/json_utils.adb @@ -28,7 +28,7 @@ with Osint; with Output; use Output; with System.OS_Lib; -package body Diagnostics.JSON_Utils is +package body JSON_Utils is ----------------- -- Begin_Block -- @@ -251,4 +251,4 @@ package body Diagnostics.JSON_Utils is Write_Char ('"'); end Write_String_Attribute; -end Diagnostics.JSON_Utils; +end JSON_Utils; diff --git a/gcc/ada/diagnostics-json_utils.ads b/gcc/ada/json_utils.ads similarity index 98% rename from gcc/ada/diagnostics-json_utils.ads rename to gcc/ada/json_utils.ads index 75adc08b40b9..b251def9a3bb 100644 --- a/gcc/ada/diagnostics-json_utils.ads +++ b/gcc/ada/json_utils.ads @@ -22,8 +22,9 @@ -- 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. @@ -77,4 +78,4 @@ package Diagnostics.JSON_Utils is -- The Value is surrounded by double quotes ("") and the special characters -- within the string are escaped. -end Diagnostics.JSON_Utils; +end JSON_Utils; diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index ac78b60094dc..12baed455d7f 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -23,12 +23,12 @@ -- -- ------------------------------------------------------------------------------ +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 @@ -899,6 +899,8 @@ 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). @@ -936,31 +938,38 @@ package body Endh is 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@!"); diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 3b470977c1b1..f4fa1ade85c8 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -26,11 +26,10 @@ 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; @@ -4038,15 +4037,18 @@ package body Sem_Aggr is 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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5bac131c1921..c76447a16985 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -29,11 +29,11 @@ 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 Elists; use Elists; +with Errid; use Errid; with Errout; use Errout; with Exp_Ch3; use Exp_Ch3; with Exp_Disp; use Exp_Disp; @@ -12170,18 +12170,15 @@ package body Sem_Ch13 is 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; @@ -15874,27 +15871,36 @@ package body Sem_Ch13 is -- 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; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d910d770ad3a..f04ee84adc1e 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -27,11 +27,11 @@ with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Debug; use Debug; -with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; +with Errid; use Errid; with Errout; use Errout; with Exp_Util; use Exp_Util; with Itypes; use Itypes; @@ -10647,86 +10647,46 @@ package body Sem_Ch4 is 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; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 031c49f0e362..e32612e4cfb9 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -28,11 +28,10 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Contracts; use Contracts; -with Debug; use Debug; -with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; +with Errid; use Errid; with Errout; use Errout; with Exp_Ch9; use Exp_Ch9; with Elists; use Elists; @@ -2200,18 +2199,21 @@ package body Sem_Ch9 is -- 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;