diff options
Diffstat (limited to 'gcc/ada')
67 files changed, 7619 insertions, 487 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b9a6f0d..02a22c6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,389 @@ +2024-09-25 Mikael Morin <mikael@gcc.gnu.org> + + PR other/116801 + * gcc-interface/lang.opt.urls: Regenerate. + +2024-09-10 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/misc.cc: Include memmodel.h before tm_p.h. + +2024-09-10 Viljar Indus <indus@adacore.com> + + * gcc-interface/decl.cc: Use same warning characters in + continuation messages. + * gcc-interface/trans.cc: Likewise. + +2024-09-10 Javier Miranda <miranda@adacore.com> + + * sem_ch13.adb (Analyze_One_Aspect): Call + Error_Msg_GNAT_Extension() to report an error when the aspect + First_Controlling_Parameter is set to True and the sources are + compiled without Core_Extensions_ Allowed. + * sem_prag.adb (Pragma_First_Controlling_Parameter): Call + subprogram Error_Msg_GNAT_Extension() to report an error when the + aspect First_Controlling_Parameter is set to True and the sources + are compiled without Core_Extensions_Allowed. Report an error when + the aspect pragma does not confirm an inherited True value. + +2024-09-10 Viljar Indus <indus@adacore.com> + + * diagnostics-pretty_emitter.adb (Get_Last_Line_Char): New. Get + the last non line change character. Write_Span_Labels use the + adjusted line end pointer to calculate the length of the span. + +2024-09-10 Piotr Trojanek <trojanek@adacore.com> + + * exp_intr.ads, exp_intr.adb (Expand_Source_Info): Move + declaration to package spec. + * sem_eval.adb (Eval_Intrinsic_Call): Evaluate calls to + GNAT.Source_Info where possible. + +2024-09-10 Piotr Trojanek <trojanek@adacore.com> + + * checks.adb (Remove_Checks): Combine CASE alternatives. + +2024-09-10 Piotr Trojanek <trojanek@adacore.com> + + * libgnat/s-os_lib.ads: Remove extra whitespace. + +2024-09-09 David Malcolm <dmalcolm@redhat.com> + + PR other/116613 + * gcc-interface/misc.cc (internal_error_function): Rename + diagnostic_context's "printer" field to "m_printer". + +2024-09-05 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (addressable_p) <COMPONENT_REF>: Add bypass + for internal fields on strict-alignment platforms. + +2024-09-05 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/gigi.h (default_field_alignment): New function. + * gcc-interface/misc.cc: Include tm_p header file. + (default_field_alignment): New function. + * gcc-interface/trans.cc (addressable_p) <COMPONENT_REF>: Replace + previous alignment klduge with call to default_field_alignment. + * gcc-interface/utils.cc (finish_record_type): Likewise for the + alignment based on which DECL_BIT_FIELD should be cleared. + +2024-09-05 Piotr Trojanek <trojanek@adacore.com> + + * exp_util.ads, exp_util.adb (Duplicate_Subexpr_No_Checks): + Remove parameters, which are no longer used. + +2024-09-05 Viljar Indus <indus@adacore.com> + + * par-endh.adb: add call to new diagnostic for end loop errors. + * sem_ch13.adb: add call to new diagnostic for default iterator + error and record representation being too late. + * sem_ch4.adb: Add new diagnostic for wrong operands. + * sem_ch9.adb: Add new diagnostic for a Lock_Free warning. + * libgnat/g-lists.adb (Ensure_Unlocked): Make checks for tampering + conditional. + * libgnat/g-lists.ads: Add parameter Tampering_Checks to control + whether tampering checks should be executed. + * backend_utils.adb: Add new gcc switches + '-fdiagnostics-format=sarif-file' and + '-fdiagnostics-format=sarif-stderr'. + * debug.adb: document -gnatd_D switch. + * diagnostics-brief_emitter.adb: New package for displaying + diagnostic messages in a compact manner. + * diagnostics-brief_emitter.ads: Same as above. + * diagnostics-constructors.adb: New pacakge for providing simpler + constructor methods for new diagnostic objects. + * diagnostics-constructors.ads: Same as above. + * diagnostics-converter.adb: New package for converting old + Error_Msg_Object-s to Diagnostic_Types. + * diagnostics-converter.ads: Same as above. + * diagnostics-json_utils.adb: Package for utility methods related + to emitting JSON. + * diagnostics-json_utils.ads: Same as above. + * diagnostics-pretty_emitter.adb: New package for displaying + diagnostic messages in a more elaborate manner. + * diagnostics-pretty_emitter.ads: Same as above. + * diagnostics-repository.adb: New package for collecting all + created error messages. + * diagnostics-repository.ads: Same as above. + * diagnostics-sarif_emitter.adb: New pacakge for converting all of + the diagnostics into a report in the SARIF format. + * diagnostics-sarif_emitter.ads: Same as above. + * diagnostics-switch_repository.adb: New package containing the + definitions for all of the warninging switches. + * diagnostics-switch_repository.ads: Same as above. + * diagnostics-utils.adb: Contains various utility methods for the + diagnostic pacakges. + * diagnostics-utils.ads: Same as above. + * diagnostics.adb: Contains the definitions and common functions + for all the new diagnostics objects. + * diagnostics.ads: Same as above. + * errout.adb: Relocate the old implementations for brief and + pretty printing the diagnostic messages and the entrypoint to the + new implementation if a debug switch is used. + * errout.ads: Improve documentation. Make Set_Msg_Text publicly + available. + * opt.ads: Add the flag SARIF_File which controls whether the + diagnostic messages should be printed to a file in the SARIF + format. Add the flag SARIF_Output to control whether the + diagnostic messages should be printed to std-err in the SARIF + format. + * gcc-interface/Make-lang.in: Add new pacakages to the object + list. + * gcc-interface/Makefile.in: Add new pacakages to the object list. + +2024-09-05 Jose Ruiz <ruiz@adacore.com> + + * ali-util.adb (Get_File_Checksum): Force the parsing for + the checksum computation of runtime files to be done in + the corresponding recent Ada version. + +2024-09-05 Ronan Desplanques <desplanques@adacore.com> + + * inline.adb (Cannot_Inline): Remove assertion. + * inline.ads (Cannot_Inline): Add precondition. + +2024-09-03 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (addressable_p) <COMPONENT_REF>: Add kludge + to cope with ancient 32-bit ABIs. + +2024-09-03 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (create_temporary): Deal with types whose + size is self-referential by allocating the maximum size. + +2024-09-03 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (get_atomic_access): Deal specifically with + nodes that are both Atomic and Volatile_Full_Access in Ada 2012. + +2024-09-03 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (addressable_p) <COMPONENT_REF>: Take into + account the alignment of the field on all platforms. + +2024-09-03 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_field): Clear again gnu_size + after updating it if it is not constant. + +2024-09-03 Marc Poulhiès <poulhies@adacore.com> + + * exp_unst.adb (Check_Static_Type::Note_Uplevel_Bound): Refactor + to use the generic Traverse_Proc. + (Check_Static_Type): Adjust calls to Note_Uplevel_Bound as the + previous second parameter was unused, so removed. + +2024-09-03 Steve Baird <baird@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): If it makes sense + to do so, then rewrite a Length attribute reference as an + equivalent conditional expression. + +2024-09-03 Eric Botcazou <ebotcazou@adacore.com> + + * sem_res.adb (Is_Atomic_Ref_With_Address): Rename into... + (Is_Atomic_Non_VFA_Ref_With_Address): ...this and adjust the + implementation to exclude Volatile_Full_Access objects. + (Resolve_Indexed_Component): Adjust to above renaming. + (Resolve_Selected_Component): Likewise. + +2024-09-03 Steve Baird <baird@adacore.com> + + * sem_aggr.adb (Resolve_Array_Aggregate): Implement the two new + legality rules of AI11-0106. Add code to avoid cascading error + messages. + +2024-09-03 Bob Duff <duff@adacore.com> + + * exp_ch6.adb (Add_Collection_Actual_To_Build_In_Place_Call): + Remove Finalize_Storage_Only from the code that checks whether to + pass null to the Collection parameter. Having done that, we don't + need to check for Is_Library_Level_Entity, because + No_Heap_Finalization requires that. And if we ever change + No_Heap_Finalization to allow nested access types, we will still + want to pass null. Note that the comment "Such a type lacks a + collection." is incorrect in the case of Finalize_Storage_Only; + such types have a collection. + +2024-09-02 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_entity): Cap the Esize of a + floating-point type to the size of the widest format supported in + hardware if it is explicity defined. + +2024-09-02 Viljar Indus <indus@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: update + documentation for the -gnatw_l switch. + * usage.adb: Add -gnatw_l entry. + * gnat_ugn.texi: Regenerate. + +2024-09-02 Ronan Desplanques <desplanques@adacore.com> + + * gnatcmd.adb (GNATCmd): Fix standard output stream. + +2024-09-02 Ronan Desplanques <desplanques@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Fix + minor issues. + * gnat_ugn.texi: Regenerate. + +2024-09-02 Bob Duff <duff@adacore.com> + + * doc/gnat_rm/gnat_language_extensions.rst: I assume "extended set + of extensions" was a typo for "experimental set of extensions", + because "extended extensions" is repetitive and redundant. "in + addition" clarifies that the one subsumes the other. Add a + reminder at the start of each subsection about what switch/pragma + enables what extensions. Add new section about "Inference of + Dependent Types in Generic Instantiations". + * gnat_rm.texi: Regenerate. + +2024-09-02 Patrick Bernardi <bernardi@adacore.com> + + * s-oscons-tmplt.c: Define sizes of pthread data types on FreeBSD. + * tracebak.c: Use GCC unwinder and adjust PC appropriately on + aarch64-freebsd. + +2024-09-02 Marc Poulhiès <poulhies@adacore.com> + + * exp_ch9.adb (Reset_Scopes_To): Adjust comment. + (Reset_Scopes_To.Reset_Scope): Adjust the scope reset for object + declaration. In particular, visit the children nodes if any. Also + extend the handling of other declarations to + N_Implicit_Label_Declaration. + +2024-09-02 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch3.adb (Expand_N_Object_Declaration): Replace calls to Sloc + with uses of Loc; turn variable Prag into constant. + +2024-09-02 Piotr Trojanek <trojanek@adacore.com> + + * exp_imgv.adb (Expand_User_Defined_Enumeration_Image) + (Expand_Image_Attribute): Remove redundant guards. + +2024-08-29 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch8.adb (Has_Private_With): Add test on Is_Entity_Name. + +2024-08-29 Eric Botcazou <ebotcazou@adacore.com> + + * checks.adb (Selected_Length_Checks.Get_E_Length): For a + component of a record with discriminants and if the expression is + a selected component, try to build an actual subtype from its + prefix instead of from the discriminal. + +2024-08-29 Steve Baird <baird@adacore.com> + + * sem_ch6.adb (Check_Discriminant_Conformance): Immediately after + calling Is_Immutably_Limited_Type, perform an additional test that + one might reasonably imagine would instead have been part of + Is_Immutably_Limited_Type. The new test is a call to a new + function Has_Tagged_Limited_Partial_View whose implementation + includes a call to Incomplete_Or_Partial_View, which cannot be + easily be called from Is_Immutably_Limited_Type (because sem_aux, + which is in the closure of the binder, cannot easily "with" + sem_util). + * sem_aux.adb (Is_Immutably_Limited): Include + N_Derived_Type_Definition case when testing Limited_Present flag. + +2024-08-29 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch6.adb (Expand_Call_Helper): In the case of a function + call, look at the Etype of the call node to determine whether + finalization actions need to be performed. + +2024-08-29 Viljar Indus <indus@adacore.com> + + * erroutc.adb (dmsg): Print Insertion_Sloc. + +2024-08-29 Viljar Indus <indus@adacore.com> + + * exp_aggr.adb (Expand_Range_Component): Remove extra warning + character. Use same conditional warning char. + * freeze.adb (Warn_Overlay): Use named warning character. + * restrict.adb (Id_Case): Use named warning character. + * sem_prag.adb (Rewrite_Assertion_Kind): Use default warning + character. + +2024-08-29 Viljar Indus <indus@adacore.com> + + * par-ch4.adb (P_Name): Use Error_Msg_Sloc for the location of the + continuation message. + +2024-08-29 Viljar Indus <indus@adacore.com> + + * exp_prag.adb (Expand_Pragma_Inspection_Point): Improve sub + diagnostic generation. + +2024-08-29 Viljar Indus <indus@adacore.com> + + * sem_ch12.adb (Abandon_Instantiation): Remove continuation + characters from the error message. + * sem_ch13.adb (Check_False_Aspect_For_Derived_Type): Remove + continuation characters from the error message. + * sem_ch6.adb (Assert_False): Avoid creating a continuation + message without a parent. If no primary message is created then + the message is considered as primary. + +2024-08-29 Viljar Indus <indus@adacore.com> + + * erroutc.adb (Prescan_Message): Avoid not parsing all of the + message attributes. + * erroutc.ads: Update the documentation. + +2024-08-29 Viljar Indus <indus@adacore.com> + + * freeze.adb: Remove warning insertion characters from a + continuation message. + * sem_util.adb: Remove warning insertion characters from a + continuation message. + * sem_warn.adb: Use same warning character as the main message. + +2024-08-29 Viljar Indus <indus@adacore.com> + + * erroutc.ads: Add new method Output_Text_Within + * erroutc.adb: Move the line fitting code to a new method called + Output_Text_Within + +2024-08-29 Piotr Trojanek <trojanek@adacore.com> + + * checks.adb (Expr_Known_Valid): Use Validated_View, which strips + type derivation and privacy. + * exp_ch3.adb (Simple_Init_Private_Type): Kill checks inside + unchecked conversions, just like in Simple_Init_Scalar_Type. + +2024-08-29 Viljar Indus <indus@adacore.com> + + * styleg.adb (Check_Line_Max_Length): Add the actual line length + to the diagnostic message. + +2024-08-29 Gary Dismukes <dismukes@adacore.com> + + * sem_aggr.adb (Resolve_Array_Aggregate): Add loop over associations to locate + N_Iterated_Component_Associations that do not have an Iterator_Specification, + and if their Discrete_Choices list consists of a single choice, analyze it and + if it's the name of an iterator object, then create an Iterator_Specification + and associate it with the iterated component association. + (Resolve_Iterated_Association): Replace test for function call with test of + Is_Object_Reference, to handle other forms of iterator objects in container + aggregates. + +2024-08-29 Javier Miranda <miranda@adacore.com> + + * usage.adb (Usage): Document switch -gnatw_j + * doc/gnat_rm/gnat_language_extensions.rst: Add documentation. + * gnat_rm.texi: Regenerate. + +2024-08-29 Justin Squirek <squirek@adacore.com> + + * doc/gnat_rm/gnat_language_extensions.rst: Move conditional when + constructs out of the curated set. + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + 2024-08-23 Robin Dapp <rdapp@ventanamicro.com> PR middle-end/115495 diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index 61dddb9..4bcb06e 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -29,6 +29,7 @@ with Opt; use Opt; with Output; use Output; with Osint; use Osint; with Scans; use Scans; +with Fname; use Fname; with Scng; with Sinput.C; with Stringt; @@ -87,8 +88,10 @@ package body ALI.Util is ----------------------- function Get_File_Checksum (Fname : File_Name_Type) return Word is - Full_Name : File_Name_Type; - Source_Index : Source_File_Index; + Full_Name : File_Name_Type; + Source_Index : Source_File_Index; + Ada_Version_Current : Ada_Version_Type; + Internal_Unit : constant Boolean := Is_Internal_File_Name (Fname); begin Full_Name := Find_File (Fname, Osint.Source); @@ -109,6 +112,15 @@ package body ALI.Util is Scanner.Initialize_Scanner (Source_Index); + -- The runtime files are precompiled with an implicitly defined Ada + -- version that we set here to improve the parsing required to compute + -- the checksum. + + if Internal_Unit then + Ada_Version_Current := Ada_Version; + Ada_Version := Ada_Version_Runtime; + end if; + -- Scan the complete file to compute its checksum loop @@ -116,6 +128,12 @@ package body ALI.Util is exit when Token = Tok_EOF; end loop; + -- Restore the Ada version if we changed it + + if Internal_Unit then + Ada_Version := Ada_Version_Current; + end if; + return Scans.Checksum; end Get_File_Checksum; diff --git a/gcc/ada/backend_utils.adb b/gcc/ada/backend_utils.adb index 3591cd1..f734a06 100644 --- a/gcc/ada/backend_utils.adb +++ b/gcc/ada/backend_utils.adb @@ -65,6 +65,21 @@ package body Backend_Utils is elsif Switch_Chars (First .. Last) = "fdiagnostics-format=json" then Opt.JSON_Output := True; + -- Back end switch -fdiagnostics-format=sarif-file tells the frontend + -- to output its error and warning messages in the sarif format. The + -- messages from gnat are written to a file <source_file>.gnat.sarif. + + elsif Switch_Chars (First .. Last) = "fdiagnostics-format=sarif-file" + then + Opt.SARIF_File := True; + + -- Back end switch -fdiagnostics-format=sarif-stderr tells the frontend + -- to output its error and warning messages in the sarif format. + + elsif Switch_Chars (First .. Last) = "fdiagnostics-format=sarif-stderr" + then + Opt.SARIF_Output := True; + -- Back-end switch -fno-inline also sets the front end flags to entirely -- inhibit all inlining. So we store it and set the appropriate -- flags. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 5d7f4cc..57307c3 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -9712,10 +9712,6 @@ package body Checks is Set_Do_Range_Check (N, False); case Nkind (N) is - when N_And_Then => - Traverse (Left_Opnd (N)); - return Skip; - when N_Attribute_Reference => Set_Do_Overflow_Check (N, False); @@ -9723,35 +9719,29 @@ package body Checks is Set_Do_Overflow_Check (N, False); case Nkind (N) is - when N_Op_Divide => - Set_Do_Division_Check (N, False); - - when N_Op_And => - Set_Do_Length_Check (N, False); - - when N_Op_Mod => - Set_Do_Division_Check (N, False); - - when N_Op_Or => - Set_Do_Length_Check (N, False); - - when N_Op_Rem => + when N_Op_Divide + | N_Op_Mod + | N_Op_Rem + => Set_Do_Division_Check (N, False); - when N_Op_Xor => + when N_Op_And + | N_Op_Or + | N_Op_Xor + => Set_Do_Length_Check (N, False); when others => null; end case; - when N_Or_Else => - Traverse (Left_Opnd (N)); - return Skip; - when N_Selected_Component => Set_Do_Discriminant_Check (N, False); + when N_Short_Circuit => + Traverse (Left_Opnd (N)); + return Skip; + when N_Type_Conversion => Set_Do_Length_Check (N, False); Set_Do_Overflow_Check (N, False); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index fcd04df..2c0bff0 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -168,8 +168,8 @@ package body Debug is -- d_A Stop generation of ALI file -- d_B Warn on build-in-place function calls -- d_C - -- d_D - -- d_E + -- d_D Use improved diagnostics + -- d_E Print diagnostics and switch repository -- d_F Encode full invocation paths in ALI files -- d_G -- d_H diff --git a/gcc/ada/diagnostics-brief_emitter.adb b/gcc/ada/diagnostics-brief_emitter.adb new file mode 100644 index 0000000..9ba137e --- /dev/null +++ b/gcc/ada/diagnostics-brief_emitter.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . B R I E F _ E M I T T E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Diagnostics.Utils; use Diagnostics.Utils; +with Erroutc; use Erroutc; +with Opt; use Opt; +with Output; use Output; + +package body Diagnostics.Brief_Emitter is + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type); + + -------------------------- + -- Print_Sub_Diagnostic -- + -------------------------- + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + is + -- In GNAT sub messages were grouped by the main messages by also having + -- the same location. In the brief printer we use the primary location + -- of the main diagnostic for all of the subdiagnostics. + Prim_Loc : constant Labeled_Span_Type := Primary_Location (Diag); + + Sptr : constant Source_Ptr := Prim_Loc.Span.Ptr; + + Text : String_Ptr; + + Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last + else Error_Msg_Line_Length); + + Switch_Str : constant String := Get_Doc_Switch (Diag); + begin + Text := new String'(To_String (Sptr) & ": " + & Kind_To_String (Sub_Diag, Diag) & ": " + & Sub_Diag.Message.all); + + if Switch_Str /= "" then + Text := new String'(Text.all & " " & Switch_Str); + end if; + + if Diag.Warn_Err then + Text := new String'(Text.all & " [warning-as-error]"); + end if; + + Output_Text_Within (Text, Line_Length); + Write_Eol; + end Print_Sub_Diagnostic; + + ---------------------- + -- Print_Diagnostic -- + ---------------------- + + procedure Print_Diagnostic (Diag : Diagnostic_Type) is + use Sub_Diagnostic_Lists; + + Prim_Loc : constant Labeled_Span_Type := Primary_Location (Diag); + + Sptr : constant Source_Ptr := Prim_Loc.Span.Ptr; + + Text : String_Ptr; + + Line_Length : constant Nat := (if Error_Msg_Line_Length = 0 then Nat'Last + else Error_Msg_Line_Length); + + Switch_Str : constant String := Get_Doc_Switch (Diag); + begin + Write_Str (To_String (Sptr) & ": "); + + -- Ignore the message prefix on Style messages. They will use + -- the (style) prefix within the message. + -- + -- Also disable the "error:" prefix if Unique_Error_Tag is unset. + + if (Diag.Kind = Style and then not Diag.Warn_Err) + or else (Diag.Kind = Error and then not Unique_Error_Tag) + then + Text := new String'(""); + else + Text := new String'(Kind_To_String (Diag) & ": "); + end if; + + Text := new String'(Text.all & Diag.Message.all); + + if Switch_Str /= "" then + Text := new String'(Text.all & " " & Switch_Str); + end if; + + if Diag.Warn_Err then + Text := new String'(Text.all & " [warning-as-error]"); + end if; + + Output_Text_Within (Text, Line_Length); + Write_Eol; + + if Present (Diag.Sub_Diagnostics) then + declare + + Sub_Diag : Sub_Diagnostic_Type; + + It : Iterator := Iterate (Diag.Sub_Diagnostics); + begin + while Has_Next (It) loop + Next (It, Sub_Diag); + + Print_Sub_Diagnostic (Sub_Diag, Diag); + end loop; + end; + end if; + + end Print_Diagnostic; +end Diagnostics.Brief_Emitter; diff --git a/gcc/ada/diagnostics-brief_emitter.ads b/gcc/ada/diagnostics-brief_emitter.ads new file mode 100644 index 0000000..1759b21 --- /dev/null +++ b/gcc/ada/diagnostics-brief_emitter.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . B R I E F _ E M I T T E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Brief_Emitter is + procedure Print_Diagnostic (Diag : Diagnostic_Type); +end Diagnostics.Brief_Emitter; diff --git a/gcc/ada/diagnostics-constructors.adb b/gcc/ada/diagnostics-constructors.adb new file mode 100644 index 0000000..8a9e10a --- /dev/null +++ b/gcc/ada/diagnostics-constructors.adb @@ -0,0 +1,475 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N S T R U C T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Sinfo.Nodes; use Sinfo.Nodes; +with Diagnostics.Utils; use Diagnostics.Utils; + +package body Diagnostics.Constructors is + + ----------------------------------------------- + -- Make_Default_Iterator_Not_Primitive_Error -- + ----------------------------------------------- + + function Make_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "improper function for default iterator", + Location => Primary_Labeled_Span (Expr), + Id => GNAT0001, + Kind => Diagnostics.Error, + Sub_Diags => + (1 => + Continuation + (Msg => + "default iterator defined " & + Sloc_To_String (Subp, Sloc (Expr)) & + " must be a primitive function", + Locations => + (1 => Primary_Labeled_Span (Subp))))); + end Make_Default_Iterator_Not_Primitive_Error; + + ------------------------------------------------- + -- Record_Default_Iterator_Not_Primitive_Error -- + ------------------------------------------------- + + procedure Record_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id) + is + begin + Record_Diagnostic + (Make_Default_Iterator_Not_Primitive_Error (Expr, Subp)); + end Record_Default_Iterator_Not_Primitive_Error; + + --------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_Error -- + --------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0002, + Kind => Diagnostics.Error, + Spans => + (1 => + (Secondary_Labeled_Span + (N => L, + Label => To_Type_Name (L_Type))), + 2 => + Secondary_Labeled_Span + (N => R, + Label => To_Type_Name (R_Type)))); + end Make_Invalid_Operand_Types_For_Operator_Error; + + ----------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_Error -- + ----------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) + is + + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_Error + (Op, L, L_Type, R, R_Type)); + end Record_Invalid_Operand_Types_For_Operator_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_L_Int_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0003, + Kind => Diagnostics.Error, + Spans => + (1 => + (Secondary_Labeled_Span + (N => L, + Label => + "left operand has type " & + To_Name (L_Type))), + 2 => + Secondary_Labeled_Span + (N => R, + Label => + "right operand has type " & + To_Name (R_Type))), + Sub_Diags => + (1 => Suggestion (Msg => "Convert left operand to ""Integer""") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_L_Int_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_L_Int_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) + is + + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op, L, L_Type, R, R_Type)); + end Record_Invalid_Operand_Types_For_Operator_L_Int_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_R_Int_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0004, + Kind => Diagnostics.Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => L, + Label => + "left operand has type " & + To_Name (L_Type)), + 2 => + Secondary_Labeled_Span + (N => R, + Label => + "right operand has type " & + To_Name (R_Type))), + Sub_Diags => + (1 => Suggestion (Msg => "Convert right operand to ""Integer""") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_R_Int_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_R_Int_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) + is + + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op, L, L_Type, R, R_Type)); + end Record_Invalid_Operand_Types_For_Operator_R_Int_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_L_Acc_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id) return Diagnostic_Type + is + + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0005, + Kind => Diagnostics.Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => L, + Label => + "left operand is access type ") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_L_Acc_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_L_Acc_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id) + is + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op, L)); + end Record_Invalid_Operand_Types_For_Operator_L_Acc_Error; + + --------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_L_Acc_Error -- + --------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id) return Diagnostic_Type + is + + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0006, + Kind => Diagnostics.Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => R, + Label => + "right operand is access type ") + ) + ); + end Make_Invalid_Operand_Types_For_Operator_R_Acc_Error; + + ----------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_R_Acc_Error -- + ----------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id) + is + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op, R)); + end Record_Invalid_Operand_Types_For_Operator_R_Acc_Error; + + ----------------------------------------------------------- + -- Make_Invalid_Operand_Types_For_Operator_General_Error -- + ----------------------------------------------------------- + + function Make_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id) return Diagnostic_Type + is + + begin + return + Make_Diagnostic + (Msg => "invalid operand types for operator " & To_Name (Op), + Location => Primary_Labeled_Span (Op), + Id => GNAT0007, + Kind => Diagnostics.Error + ); + end Make_Invalid_Operand_Types_For_Operator_General_Error; + + ------------------------------------------------------------- + -- Record_Invalid_Operand_Types_For_Operator_General_Error -- + ------------------------------------------------------------- + + procedure Record_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id) + is + begin + Record_Diagnostic + (Make_Invalid_Operand_Types_For_Operator_General_Error (Op)); + end Record_Invalid_Operand_Types_For_Operator_General_Error; + + -------------------------------------------------- + -- Make_Pragma_No_Effect_With_Lock_Free_Warning -- + -------------------------------------------------- + + function Make_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; Lock_Free_Range : Node_Id) + return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => + "pragma " & '"' & Get_Name_String (Pragma_Name) & '"' & + " for " & To_Name (Lock_Free_Node) & + " has no effect when Lock_Free given", + Location => Primary_Labeled_Span (Pragma_Node, "No effect"), + Id => GNAT0008, + Kind => Diagnostics.Warning, + Spans => + (1 => + Labeled_Span + (Span => To_Full_Span (Lock_Free_Range), + Label => "Lock_Free in effect here", + Is_Primary => False, + Is_Region => True))); + end Make_Pragma_No_Effect_With_Lock_Free_Warning; + + -------------------------------------------- + -- Record_Pragma_No_Effect_With_Lock_Free -- + -------------------------------------------- + + procedure Record_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; + Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; + Lock_Free_Range : Node_Id) + is + begin + Record_Diagnostic + (Make_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node, Pragma_Name, Lock_Free_Node, Lock_Free_Range)); + end Record_Pragma_No_Effect_With_Lock_Free_Warning; + + ---------------------------------- + -- Make_End_Loop_Expected_Error -- + ---------------------------------- + + function Make_End_Loop_Expected_Error + (End_Loc : Source_Span; + Start_Loc : Source_Ptr) return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => + """end loop;"" expected for ""loop"" " & + Sloc_To_String (Start_Loc, End_Loc.Ptr), + Location => Primary_Labeled_Span (End_Loc), + Id => GNAT0009, + Kind => Diagnostics.Error, + Spans => (1 => Secondary_Labeled_Span (To_Span (Start_Loc))), + Fixes => + (1 => + Fix + (Description => "Replace with 'end loop;'", + Edits => + (1 => Edit (Text => "end loop;", Span => End_Loc)), + Applicability => Legal))); + end Make_End_Loop_Expected_Error; + + ------------------------------------ + -- Record_End_Loop_Expected_Error -- + ------------------------------------ + + procedure Record_End_Loop_Expected_Error + (End_Loc : Source_Span; Start_Loc : Source_Ptr) + is + begin + Record_Diagnostic (Make_End_Loop_Expected_Error (End_Loc, Start_Loc)); + end Record_End_Loop_Expected_Error; + + ---------------------------------------- + -- Make_Representation_Too_Late_Error -- + ---------------------------------------- + + function Make_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id) + return Diagnostic_Type + is + begin + return + Make_Diagnostic + (Msg => + "record representation cannot be specified" & + " after the type is frozen", + Location => + Primary_Labeled_Span + (N => Rep, + Label => "record representation clause specified here"), + Id => GNAT0010, + Kind => Error, + Spans => + (1 => + Secondary_Labeled_Span + (N => Freeze, + Label => + "Type " & To_Name (Def) & " is frozen here"), + 2 => + Secondary_Labeled_Span + (N => Def, + Label => + "Type " & To_Name (Def) & " is declared here")), + Sub_Diags => + (1 => + Suggestion + (Msg => + "move the record representation clause" & + " before the freeze point " & + Sloc_To_String (Sloc (Freeze), Sloc (Rep))))); + end Make_Representation_Too_Late_Error; + + ------------------------------------------ + -- Record_Representation_Too_Late_Error -- + ------------------------------------------ + + procedure Record_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id) + is + begin + Record_Diagnostic + (Make_Representation_Too_Late_Error (Rep, Freeze, Def)); + end Record_Representation_Too_Late_Error; + +end Diagnostics.Constructors; diff --git a/gcc/ada/diagnostics-constructors.ads b/gcc/ada/diagnostics-constructors.ads new file mode 100644 index 0000000..96782b3 --- /dev/null +++ b/gcc/ada/diagnostics-constructors.ads @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N S T R U C T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Namet; use Namet; + +package Diagnostics.Constructors is + + function Make_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id) return Diagnostic_Type; + + procedure Record_Default_Iterator_Not_Primitive_Error + (Expr : Node_Id; + Subp : Entity_Id); + + function Make_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op : Node_Id; + L : Node_Id; + L_Type : Node_Id; + R : Node_Id; + R_Type : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op : Node_Id; + L : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op : Node_Id; + R : Node_Id); + + function Make_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id) return Diagnostic_Type; + + procedure Record_Invalid_Operand_Types_For_Operator_General_Error + (Op : Node_Id); + + function Make_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; + Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; + Lock_Free_Range : Node_Id) + return Diagnostic_Type; + + procedure Record_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node : Node_Id; + Pragma_Name : Name_Id; + Lock_Free_Node : Node_Id; + Lock_Free_Range : Node_Id); + + function Make_End_Loop_Expected_Error + (End_Loc : Source_Span; + Start_Loc : Source_Ptr) return Diagnostic_Type; + + procedure Record_End_Loop_Expected_Error + (End_Loc : Source_Span; + Start_Loc : Source_Ptr); + + function Make_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id) + return Diagnostic_Type; + + procedure Record_Representation_Too_Late_Error + (Rep : Node_Id; + Freeze : Node_Id; + Def : Node_Id); + +end Diagnostics.Constructors; diff --git a/gcc/ada/diagnostics-converter.adb b/gcc/ada/diagnostics-converter.adb new file mode 100644 index 0000000..45bb19c --- /dev/null +++ b/gcc/ada/diagnostics-converter.adb @@ -0,0 +1,281 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N V E R T E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Erroutc; use Erroutc; +with Debug; use Debug; +with Diagnostics.Repository; use Diagnostics.Repository; +with Diagnostics.SARIF_Emitter; use Diagnostics.SARIF_Emitter; +with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +use Diagnostics.Diagnostics_Lists; +with System.OS_Lib; use System.OS_Lib; + +package body Diagnostics.Converter is + + function Convert (E_Id : Error_Msg_Id) return Diagnostic_Type; + + function Convert_Sub_Diagnostic + (E_Id : Error_Msg_Id) return Sub_Diagnostic_Type; + + function Get_Warning_Kind (E_Msg : Error_Msg_Object) return Diagnostic_Kind + is (if E_Msg.Info then Info_Warning + elsif E_Msg.Warn_Chr = "* " then Restriction_Warning + elsif E_Msg.Warn_Chr = "? " then Default_Warning + elsif E_Msg.Warn_Chr = " " then Tagless_Warning + else Warning); + -- NOTE: Some messages have both info and warning set to true. The old + -- printer added the warning switch label but treated the message as + -- an info message. + + ----------------------------------- + -- Convert_Errors_To_Diagnostics -- + ----------------------------------- + + procedure Convert_Errors_To_Diagnostics + is + E : Error_Msg_Id; + begin + E := First_Error_Msg; + while E /= No_Error_Msg loop + + if not Errors.Table (E).Deleted + and then not Errors.Table (E).Msg_Cont + then + + -- We do not need to update the count of converted error messages + -- since they are accounted for in their creation. + + Record_Diagnostic (Convert (E), Update_Count => False); + end if; + + E := Errors.Table (E).Next; + end loop; + + end Convert_Errors_To_Diagnostics; + + ---------------------------- + -- Convert_Sub_Diagnostic -- + ---------------------------- + + function Convert_Sub_Diagnostic + (E_Id : Error_Msg_Id) return Sub_Diagnostic_Type + is + E_Msg : constant Error_Msg_Object := Errors.Table (E_Id); + D : Sub_Diagnostic_Type; + begin + D.Message := E_Msg.Text; + + -- All converted sub-diagnostics are continuations. When emitted they + -- shall be printed with the same kind token as the main diagnostic. + D.Kind := Continuation; + + declare + L : Labeled_Span_Type; + begin + if E_Msg.Insertion_Sloc /= No_Location then + L.Span := To_Span (E_Msg.Insertion_Sloc); + else + L.Span := E_Msg.Sptr; + end if; + + L.Is_Primary := True; + Add_Location (D, L); + end; + + if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then + declare + L : Labeled_Span_Type; + begin + L.Span := E_Msg.Optr; + L.Is_Primary := False; + Add_Location (D, L); + end; + end if; + + return D; + end Convert_Sub_Diagnostic; + + ------------- + -- Convert -- + ------------- + + function Convert (E_Id : Error_Msg_Id) return Diagnostic_Type is + + E_Next_Id : Error_Msg_Id; + + E_Msg : constant Error_Msg_Object := Errors.Table (E_Id); + D : Diagnostic_Type; + begin + D.Message := E_Msg.Text; + + if E_Msg.Warn then + D.Kind := Get_Warning_Kind (E_Msg); + D.Switch := Get_Switch_Id (E_Msg); + elsif E_Msg.Style then + D.Kind := Style; + D.Switch := Get_Switch_Id (E_Msg); + elsif E_Msg.Info then + D.Kind := Info; + D.Switch := Get_Switch_Id (E_Msg); + else + D.Kind := Error; + end if; + + D.Warn_Err := E_Msg.Warn_Err; + + D.Serious := E_Msg.Serious; + + -- Convert the primary location + + declare + L : Labeled_Span_Type; + begin + L.Span := E_Msg.Sptr; + L.Is_Primary := True; + Add_Location (D, L); + end; + + -- Convert the secondary location if it is different from the primary + + if E_Msg.Optr.Ptr /= E_Msg.Sptr.Ptr then + declare + L : Labeled_Span_Type; + begin + L.Span := E_Msg.Optr; + L.Is_Primary := False; + Add_Location (D, L); + end; + end if; + + E_Next_Id := Errors.Table (E_Id).Next; + while E_Next_Id /= No_Error_Msg + and then Errors.Table (E_Next_Id).Msg_Cont + loop + Add_Sub_Diagnostic (D, Convert_Sub_Diagnostic (E_Next_Id)); + E_Next_Id := Errors.Table (E_Next_Id).Next; + end loop; + + return D; + end Convert; + + ---------------------- + -- Emit_Diagnostics -- + ---------------------- + + procedure Emit_Diagnostics is + D : Diagnostic_Type; + + It : Iterator := Iterate (All_Diagnostics); + + Sarif_File_Name : constant String := + Get_First_Main_File_Name & ".gnat.sarif"; + + Switches_File_Name : constant String := "gnat_switches.json"; + + Diagnostics_File_Name : constant String := "gnat_diagnostics.json"; + + Dummy : Boolean; + begin + if Opt.SARIF_Output then + Set_Standard_Error; + + Print_SARIF_Report (All_Diagnostics); + + Set_Standard_Output; + elsif Opt.SARIF_File then + Delete_File (Sarif_File_Name, Dummy); + declare + Output_FD : constant File_Descriptor := + Create_New_File + (Sarif_File_Name, + Fmode => Text); + + begin + Set_Output (Output_FD); + + Print_SARIF_Report (All_Diagnostics); + + Set_Standard_Output; + + Close (Output_FD); + end; + else + Set_Standard_Error; + + while Has_Next (It) loop + Next (It, D); + + Print_Diagnostic (D); + end loop; + + Set_Standard_Output; + end if; + + if Debug_Flag_Underscore_EE then + + -- Print the switch repository to a file + + Delete_File (Switches_File_Name, Dummy); + declare + Output_FD : constant File_Descriptor := + Create_New_File + (Switches_File_Name, + Fmode => Text); + + begin + Set_Output (Output_FD); + + Print_Switch_Repository; + + Set_Standard_Output; + + Close (Output_FD); + end; + + -- Print the diagnostics repository to a file + + Delete_File (Diagnostics_File_Name, Dummy); + declare + Output_FD : constant File_Descriptor := + Create_New_File + (Diagnostics_File_Name, + Fmode => Text); + + begin + Set_Output (Output_FD); + + Print_Diagnostic_Repository; + + Set_Standard_Output; + + Close (Output_FD); + end; + end if; + + Destroy (All_Diagnostics); + end Emit_Diagnostics; + +end Diagnostics.Converter; diff --git a/gcc/ada/diagnostics-converter.ads b/gcc/ada/diagnostics-converter.ads new file mode 100644 index 0000000..8436ed1 --- /dev/null +++ b/gcc/ada/diagnostics-converter.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . C O N V E R T E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Converter is + + procedure Convert_Errors_To_Diagnostics; + + procedure Emit_Diagnostics; +end Diagnostics.Converter; diff --git a/gcc/ada/diagnostics-json_utils.adb b/gcc/ada/diagnostics-json_utils.adb new file mode 100644 index 0000000..30263b0 --- /dev/null +++ b/gcc/ada/diagnostics-json_utils.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . J S O N _ U T I L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Output; use Output; + +package body Diagnostics.JSON_Utils is + + ----------------- + -- Begin_Block -- + ----------------- + + procedure Begin_Block is + begin + Indent_Level := Indent_Level + 1; + end Begin_Block; + + --------------- + -- End_Block -- + --------------- + + procedure End_Block is + begin + Indent_Level := Indent_Level - 1; + end End_Block; + + procedure Indent is begin + if JSON_FORMATTING then + for I in 1 .. INDENT_SIZE * Indent_Level loop + Write_Char (' '); + end loop; + end if; + end Indent; + + ------------------- + -- NL_And_Indent -- + ------------------- + + procedure NL_And_Indent is + begin + if JSON_FORMATTING then + Write_Eol; + Indent; + end if; + end NL_And_Indent; + + ------------------------- + -- Write_Int_Attribute -- + ------------------------- + + procedure Write_Int_Attribute (Name : String; Value : Int) is + begin + Write_Str ("""" & Name & """" & ": "); + Write_Int (Value); + end Write_Int_Attribute; + + ------------------------------- + -- Write_JSON_Escaped_String -- + ------------------------------- + + procedure Write_JSON_Escaped_String (Str : String) is + begin + for C of Str loop + if C = '"' or else C = '\' then + Write_Char ('\'); + end if; + + Write_Char (C); + end loop; + end Write_JSON_Escaped_String; + + ---------------------------- + -- Write_String_Attribute -- + ---------------------------- + + procedure Write_String_Attribute (Name : String; Value : String) is + begin + Write_Str ("""" & Name & """" & ": "); + Write_Char ('"'); + Write_JSON_Escaped_String (Value); + Write_Char ('"'); + end Write_String_Attribute; + +end Diagnostics.JSON_Utils; diff --git a/gcc/ada/diagnostics-json_utils.ads b/gcc/ada/diagnostics-json_utils.ads new file mode 100644 index 0000000..1fc6c0e --- /dev/null +++ b/gcc/ada/diagnostics-json_utils.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . J S O N _ U T I L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.JSON_Utils is + + JSON_FORMATTING : constant Boolean := True; + -- Adds newlines and indentation to the output JSON. + -- + -- NOTE: This flag could be associated with the gcc switch: + -- '-fno-diagnostics-json-formatting' + + INDENT_SIZE : constant := 2; + -- The number of spaces to indent each level of the JSON output. + + Indent_Level : Natural := 0; + -- The current indentation level. + + procedure Begin_Block; + -- Increase the indentation level by one + + procedure End_Block; + -- Decrease the indentation level by one + + procedure Indent; + -- Print the indentation for the line + + procedure NL_And_Indent; + -- Print a new line + + procedure Write_Int_Attribute (Name : String; Value : Int); + + procedure Write_JSON_Escaped_String (Str : String); + -- Write each character of Str, taking care of preceding each quote and + -- backslash with a backslash. Note that this escaping differs from what + -- GCC does. + -- + -- Indeed, the JSON specification mandates encoding wide characters + -- either as their direct UTF-8 representation or as their escaped + -- UTF-16 surrogate pairs representation. GCC seems to prefer escaping - + -- we choose to use the UTF-8 representation instead. + + procedure Write_String_Attribute (Name : String; Value : String); + -- Write a JSON attribute with a string value + +end Diagnostics.JSON_Utils; diff --git a/gcc/ada/diagnostics-pretty_emitter.adb b/gcc/ada/diagnostics-pretty_emitter.adb new file mode 100644 index 0000000..389be8a --- /dev/null +++ b/gcc/ada/diagnostics-pretty_emitter.adb @@ -0,0 +1,1301 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . P R E T T Y _ E M I T T E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Diagnostics.Utils; use Diagnostics.Utils; +with Output; use Output; +with Sinput; use Sinput; +with Erroutc; use Erroutc; + +package body Diagnostics.Pretty_Emitter is + + REGION_OFFSET : constant := 1; + -- Number of characters between the line bar and the region span + + REGION_ARM_SIZE : constant := 2; + -- Number of characters on the region span arms + -- e.g. two for this case: + -- +-- + -- | + -- +-- + -- ^^ + + REGION_SIZE : constant := REGION_OFFSET + 1 + REGION_ARM_SIZE; + -- The total number of characters taken up by the region span characters + + MAX_BAR_POS : constant := 7; + -- The maximum position of the line bar from the start of the line + type Printable_Line is record + First : Source_Ptr; + -- The first character of the line + + Last : Source_Ptr; + -- The last character of the line + + Line_Nr : Pos; + -- The line number + + Spans : Labeled_Span_List; + -- The spans applied on the line + end record; + + procedure Destroy (Elem : in out Printable_Line); + pragma Inline (Destroy); + + function Equals (L, R : Printable_Line) return Boolean is + (L.Line_Nr = R.Line_Nr); + + package Lines_Lists is new Doubly_Linked_Lists + (Element_Type => Printable_Line, + "=" => Equals, + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Lines_List is Lines_Lists.Doubly_Linked_List; + + type File_Sections is record + File : String_Ptr; + -- Name of the file + + Lines : Lines_List; + -- Lines to be printed for the file + end record; + + procedure Destroy (Elem : in out File_Sections); + pragma Inline (Destroy); + + function Equals (L, R : File_Sections) return Boolean is + (L.File /= null + and then R.File /= null + and then L.File.all = R.File.all); + + package File_Section_Lists is new Doubly_Linked_Lists + (Element_Type => File_Sections, + "=" => Equals, + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype File_Section_List is File_Section_Lists.Doubly_Linked_List; + + function Create_File_Sections (Spans : Labeled_Span_List) + return File_Section_List; + -- Create a list of file sections from the labeled spans that are to be + -- printed. + -- + -- Each file section contains a list of lines that are to be printed for + -- the file and the spans that are applied to each of those lines. + + procedure Create_File_Section + (Sections : in out File_Section_List; + Loc : Labeled_Span_Type); + -- Create a new file section for the given labeled span. + + procedure Add_Printable_Line + (Lines : Lines_List; + Loc : Labeled_Span_Type; + S_Ptr : Source_Ptr); + + procedure Create_Printable_Line + (Lines : Lines_List; + Loc : Labeled_Span_Type; + S_Ptr : Source_Ptr); + -- Create a new printable line for the given labeled span and add it in the + -- correct position to the Lines list based on the line number. + + function Has_Region_Span_Start (L : Printable_Line) return Boolean; + function Has_Region_Span_End (L : Printable_Line) return Boolean; + + function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean; + + procedure Write_Region_Delimiter; + -- Write the arms signifying the start and end of a region span + -- e.g. +-- + + procedure Write_Region_Bar; + -- Write the bar signifying the continuation of a region span + -- e.g. | + + procedure Write_Region_Continuation; + -- Write the continuation signifying the continuation of a region span + -- e.g. : + + procedure Write_Region_Offset; + -- Write a number of whitespaces equal to the size of the region span + + function Trimmed_Image (I : Natural) return String; + + procedure Write_Span_Labels (Loc : Labeled_Span_Type; + L : Printable_Line; + Line_Size : Integer; + Idx : String; + Within_Region_Span : Boolean); + + procedure Write_File_Section (Sec : File_Sections; + Write_File_Name : Boolean; + File_Name_Offset : Integer); + + procedure Write_Labeled_Spans (Spans : Labeled_Span_List; + Write_File_Name : Boolean; + File_Name_Offset : Integer); + + procedure Write_Intersecting_Labels + (Intersecting_Labels : Labeled_Span_List); + + function Get_Line_End + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr; + -- Get the source location for the end of the line (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; + -- Get the source location for the start of the line in Buf for Loc + + function Get_First_Line_Char + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; + -- Get first non-space character in the line containing Loc + + function Get_Last_Line_Char + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; + -- Get last non line end [LF, CR] character in the line containing Loc + + function Image (X : Positive; Width : Positive) return String; + -- Output number X over Width characters, with whitespace padding. + -- Only output the low-order Width digits of X, if X is larger than + -- Width digits. + + procedure Write_Buffer + (Buf : Source_Buffer_Ptr; + First : Source_Ptr; + Last : Source_Ptr); + -- Output the characters from First to Last position in Buf, using + -- Write_Buffer_Char. + + procedure Write_Buffer_Char + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr); + -- Output the characters at position Loc in Buf, translating ASCII.HT + -- in a suitable number of spaces so that the output is not modified + -- by starting in a different column that 1. + + procedure Write_Line_Marker + (Num : Pos; + Width : Positive); + + procedure Write_Empty_Bar_Line (Width : Integer); + + procedure Write_Empty_Skip_Line (Width : Integer); + + procedure Write_Error_Msg_Line (Diag : Diagnostic_Type); + -- Write the error message line for the given diagnostic: + -- + -- '['<Diag.Id>']' <Diag.Kind>: <Diag.Message> ['['<Diag.Switch>']'] + + function Should_Write_File_Name (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) return Boolean; + -- If the sub-diagnostic and the main diagnostic only point to the same + -- file then there is no reason to add the file name to the sub-diagnostic. + + function Should_Write_Spans (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + return Boolean; + -- Old sub-diagnostics used to have the same location as the main + -- diagnostic in order to group them correctly. However in most cases + -- it was not meant to point to a location but rather add an additional + -- message to the original diagnostic. + -- + -- If the sub-diagnostic and the main diagnostic have the same location + -- then we should avoid printing the spans. + + procedure Print_Edit + (Edit : Edit_Type; + Offset : Integer); + + procedure Print_Fix + (Fix : Fix_Type; + Offset : Integer); + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type; + Offset : Integer); + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Printable_Line) + is + begin + -- Diagnostic elements will be freed when all the diagnostics have been + -- emitted. + null; + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out File_Sections) + is + begin + Free (Elem.File); + end Destroy; + + ------------------ + -- Get_Line_End -- + ------------------ + + function Get_Line_End + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr + is + Cur_Loc : Source_Ptr := Source_Ptr'Min (Loc, Buf'Last); + begin + while Cur_Loc < Buf'Last + and then Buf (Cur_Loc) /= ASCII.LF + loop + Cur_Loc := Cur_Loc + 1; + end loop; + + return Cur_Loc; + end Get_Line_End; + + -------------------- + -- Get_Line_Start -- + -------------------- + + function Get_Line_Start + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr + is + Cur_Loc : Source_Ptr := Loc; + begin + while Cur_Loc > Buf'First + and then Buf (Cur_Loc - 1) /= ASCII.LF + loop + Cur_Loc := Cur_Loc - 1; + end loop; + + return Cur_Loc; + end Get_Line_Start; + + ------------------------- + -- Get_First_Line_Char -- + ------------------------- + + function Get_First_Line_Char + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr + is + Cur_Loc : Source_Ptr := Get_Line_Start (Buf, Loc); + begin + while Cur_Loc < Buf'Last + and then Buf (Cur_Loc) = ' ' + loop + Cur_Loc := Cur_Loc + 1; + end loop; + + return Cur_Loc; + end Get_First_Line_Char; + + ------------------------ + -- Get_Last_Line_Char -- + ------------------------ + + function Get_Last_Line_Char + (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr + is + Cur_Loc : Source_Ptr := Get_Line_End (Buf, Loc); + begin + + while Cur_Loc > Buf'First + and then Buf (Cur_Loc) in ASCII.LF | ASCII.CR + loop + Cur_Loc := Cur_Loc - 1; + end loop; + + return Cur_Loc; + end Get_Last_Line_Char; + + ----------- + -- Image -- + ----------- + + function Image (X : Positive; Width : Positive) return String is + Str : String (1 .. Width); + Curr : Natural := X; + begin + for J in reverse 1 .. Width loop + if Curr > 0 then + Str (J) := Character'Val (Character'Pos ('0') + Curr mod 10); + Curr := Curr / 10; + else + Str (J) := ' '; + end if; + end loop; + + return Str; + end Image; + + -------------------------------- + -- Has_Multiple_Labeled_Spans -- + -------------------------------- + + function Has_Multiple_Labeled_Spans (L : Printable_Line) return Boolean + is + Count : Natural := 0; + + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (L.Spans); + begin + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + if Loc.Label /= null then + Count := Count + 1; + end if; + end loop; + + return Count > 1; + end Has_Multiple_Labeled_Spans; + + --------------------------- + -- Has_Region_Span_Start -- + --------------------------- + + function Has_Region_Span_Start (L : Printable_Line) return Boolean is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (L.Spans); + + Has_Region_Start : Boolean := False; + begin + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + if not Has_Region_Start + and then Loc.Is_Region + and then L.Line_Nr = + Pos (Get_Physical_Line_Number (Loc.Span.First)) + then + Has_Region_Start := True; + end if; + end loop; + return Has_Region_Start; + end Has_Region_Span_Start; + + ------------------------- + -- Has_Region_Span_End -- + ------------------------- + + function Has_Region_Span_End (L : Printable_Line) return Boolean is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (L.Spans); + + Has_Region_End : Boolean := False; + begin + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + if not Has_Region_End + and then Loc.Is_Region + and then L.Line_Nr = + Pos (Get_Physical_Line_Number (Loc.Span.Last)) + then + Has_Region_End := True; + end if; + end loop; + return Has_Region_End; + end Has_Region_Span_End; + + ------------------ + -- Write_Buffer -- + ------------------ + + procedure Write_Buffer + (Buf : Source_Buffer_Ptr; + First : Source_Ptr; + Last : Source_Ptr) + is + begin + for Loc in First .. Last loop + Write_Buffer_Char (Buf, Loc); + end loop; + end Write_Buffer; + + ----------------------- + -- Write_Buffer_Char -- + ----------------------- + + procedure Write_Buffer_Char + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) + is + begin + -- If the character ASCII.HT is not the last one in the file, + -- output as many spaces as the character represents in the + -- original source file. + + if Buf (Loc) = ASCII.HT + and then Loc < Buf'Last + then + for X in Get_Column_Number (Loc) .. + Get_Column_Number (Loc + 1) - 1 + loop + Write_Char (' '); + end loop; + + -- Otherwise output the character itself + + else + Write_Char (Buf (Loc)); + end if; + end Write_Buffer_Char; + + ----------------------- + -- Write_Line_Marker -- + ----------------------- + + procedure Write_Line_Marker + (Num : Pos; + Width : Positive) + is + begin + Write_Str (Image (Positive (Num), Width => Width - 2)); + Write_Str (" |"); + end Write_Line_Marker; + + -------------------------- + -- Write_Empty_Bar_Line -- + -------------------------- + + procedure Write_Empty_Bar_Line (Width : Integer) is + + begin + Write_Str (String'(1 .. Width - 1 => ' ')); + Write_Str ("|"); + end Write_Empty_Bar_Line; + + --------------------------- + -- Write_Empty_Skip_Line -- + --------------------------- + + procedure Write_Empty_Skip_Line (Width : Integer) is + + begin + Write_Str (String'(1 .. Width - 1 => ' ')); + Write_Str (":"); + end Write_Empty_Skip_Line; + + ---------------------------- + -- Write_Region_Delimiter -- + ---------------------------- + + procedure Write_Region_Delimiter is + + begin + Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str ("+"); + Write_Str (String'(1 .. REGION_ARM_SIZE => '-')); + end Write_Region_Delimiter; + + ---------------------- + -- Write_Region_Bar -- + ---------------------- + + procedure Write_Region_Bar is + + begin + Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str ("|"); + Write_Str (String'(1 .. REGION_ARM_SIZE => ' ')); + end Write_Region_Bar; + + ------------------------------- + -- Write_Region_Continuation -- + ------------------------------- + + procedure Write_Region_Continuation is + + begin + Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str (":"); + Write_Str (String'(1 .. REGION_ARM_SIZE => ' ')); + end Write_Region_Continuation; + + ------------------------- + -- Write_Region_Offset -- + ------------------------- + + procedure Write_Region_Offset is + + begin + Write_Str (String'(1 .. REGION_SIZE => ' ')); + end Write_Region_Offset; + + ------------------------ + -- Add_Printable_Line -- + ------------------------ + + procedure Add_Printable_Line + (Lines : Lines_List; + Loc : Labeled_Span_Type; + S_Ptr : Source_Ptr) + is + L : Printable_Line; + L_It : Lines_Lists.Iterator; + + Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr)); + Line_Found : Boolean := False; + begin + L_It := Lines_Lists.Iterate (Lines); + while Lines_Lists.Has_Next (L_It) loop + Lines_Lists.Next (L_It, L); + + if not Line_Found and then L.Line_Nr = Line_Ptr then + if not Labeled_Span_Lists.Contains (L.Spans, Loc) then + Labeled_Span_Lists.Append (L.Spans, Loc); + end if; + Line_Found := True; + end if; + end loop; + + if not Line_Found then + Create_Printable_Line (Lines, Loc, S_Ptr); + end if; + end Add_Printable_Line; + + --------------------------- + -- Create_Printable_Line -- + --------------------------- + + procedure Create_Printable_Line + (Lines : Lines_List; + Loc : Labeled_Span_Type; + S_Ptr : Source_Ptr) + is + Spans : constant Labeled_Span_List := Labeled_Span_Lists.Create; + + Buf : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (S_Ptr)); + + Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (S_Ptr)); + + New_Line : constant Printable_Line := + (First => Get_Line_Start (Buf, S_Ptr), + Last => Get_Line_End (Buf, S_Ptr), + Line_Nr => Line_Nr, + Spans => Spans); + + L : Printable_Line; + L_It : Lines_Lists.Iterator := Lines_Lists.Iterate (Lines); + + Found_Greater_Line : Boolean := False; + Insert_Before_Line : Printable_Line; + begin + Labeled_Span_Lists.Append (Spans, Loc); + + -- Insert the new line based on the line number + + while Lines_Lists.Has_Next (L_It) loop + Lines_Lists.Next (L_It, L); + + if not Found_Greater_Line + and then L.Line_Nr > New_Line.Line_Nr + then + Found_Greater_Line := True; + Insert_Before_Line := L; + + Lines_Lists.Insert_Before (Lines, Insert_Before_Line, New_Line); + end if; + end loop; + + if Found_Greater_Line then + + -- Insert after all the lines have been iterated over to avoid the + -- mutation lock in GNAT.Lists + + null; + else + Lines_Lists.Append (Lines, New_Line); + end if; + end Create_Printable_Line; + + ------------------------- + -- Create_File_Section -- + ------------------------- + + procedure Create_File_Section + (Sections : in out File_Section_List; Loc : Labeled_Span_Type) + is + Lines : constant Lines_List := Lines_Lists.Create; + + -- Carret positions + Ptr : constant Source_Ptr := Loc.Span.Ptr; + Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (Ptr)); + + -- Span start positions + Fst : constant Source_Ptr := Loc.Span.First; + Line_Fst : constant Pos := Pos (Get_Physical_Line_Number (Fst)); + + -- Span end positions + Lst : constant Source_Ptr := Loc.Span.Last; + Line_Lst : constant Pos := Pos (Get_Physical_Line_Number (Lst)); + begin + Create_Printable_Line (Lines, Loc, Fst); + + if Line_Fst /= Line_Ptr then + Create_Printable_Line (Lines, Loc, Ptr); + end if; + + if Line_Ptr /= Line_Lst then + Create_Printable_Line (Lines, Loc, Lst); + end if; + + File_Section_Lists.Append + (Sections, + (File => new String'(To_File_Name (Loc.Span.Ptr)), + Lines => Lines)); + end Create_File_Section; + + -------------------------- + -- Create_File_Sections -- + -------------------------- + + function Create_File_Sections + (Spans : Labeled_Span_List) return File_Section_List + is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Spans); + + Sections : File_Section_List := File_Section_Lists.Create; + + Sec : File_Sections; + F_It : File_Section_Lists.Iterator; + + File_Found : Boolean; + begin + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + File_Found := False; + F_It := File_Section_Lists.Iterate (Sections); + + while File_Section_Lists.Has_Next (F_It) loop + File_Section_Lists.Next (F_It, Sec); + + if Sec.File /= null + and then Sec.File.all = To_File_Name (Loc.Span.Ptr) + then + File_Found := True; + + Add_Printable_Line (Sec.Lines, Loc, Loc.Span.First); + + Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Ptr); + + Add_Printable_Line (Sec.Lines, Loc, Loc.Span.Last); + end if; + end loop; + + if not File_Found then + Create_File_Section (Sections, Loc); + end if; + end loop; + + return Sections; + end Create_File_Sections; + + ----------------------- + -- Write_Span_Labels -- + ----------------------- + + procedure Write_Span_Labels (Loc : Labeled_Span_Type; + L : Printable_Line; + Line_Size : Integer; + Idx : String; + Within_Region_Span : Boolean) + is + Span_Char : constant Character := (if Loc.Is_Primary then '~' else '-'); + + Buf : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (L.First)); + + Col_L_Fst : constant Natural := Natural + (Get_Column_Number (Get_First_Line_Char (Buf, L.First))); + Col_L_Lst : constant Natural := Natural + (Get_Column_Number (Get_Last_Line_Char (Buf, L.Last))); + + -- Carret positions + Ptr : constant Source_Ptr := Loc.Span.Ptr; + Line_Ptr : constant Pos := Pos (Get_Physical_Line_Number (Ptr)); + Col_Ptr : constant Natural := Natural (Get_Column_Number (Ptr)); + + -- Span start positions + Fst : constant Source_Ptr := Loc.Span.First; + Line_Fst : constant Pos := Pos (Get_Physical_Line_Number (Fst)); + Col_Fst : constant Natural := Natural (Get_Column_Number (Fst)); + + -- Span end positions + Lst : constant Source_Ptr := Loc.Span.Last; + Line_Lst : constant Pos := Pos (Get_Physical_Line_Number (Lst)); + Col_Lst : constant Natural := Natural (Get_Column_Number (Lst)); + + -- Attributes for the span on the current line + + Span_Sym : constant String := (if Idx = "" then "^" else Idx); + + Span_Fst : constant Natural := + (if Line_Fst = L.Line_Nr then Col_Fst else Col_L_Fst); + + Span_Lst : constant Natural := + (if Line_Lst = L.Line_Nr then Col_Lst else Col_L_Lst); + + Span_Ptr_Fst : constant Natural := + (if Line_Ptr = L.Line_Nr then Col_Ptr else Col_L_Fst); + + Span_Ptr_Lst : constant Natural := + (if Line_Ptr = L.Line_Nr + then Span_Ptr_Fst + Span_Sym'Length + else Span_Fst); + + begin + if not Loc.Is_Region then + Write_Empty_Bar_Line (Line_Size); + + if Within_Region_Span then + Write_Region_Bar; + else + Write_Region_Offset; + end if; + + Write_Str (String'(1 .. Span_Fst - 1 => ' ')); + + if Line_Ptr = L.Line_Nr then + Write_Str (String'(Span_Fst .. Col_Ptr - 1 => Span_Char)); + Write_Str (Span_Sym); + end if; + + Write_Str (String'(Span_Ptr_Lst .. Span_Lst => Span_Char)); + + Write_Eol; + + -- Write the label under the line unless it is an intersecting span. + -- In this case omit the label which will be printed later along with + -- the index. + + if Loc.Label /= null and then Idx = "" then + Write_Empty_Bar_Line (Line_Size); + + if Within_Region_Span then + Write_Region_Bar; + else + Write_Region_Offset; + end if; + + Write_Str (String'(1 .. Span_Fst - 1 => ' ')); + Write_Str (Loc.Label.all); + Write_Eol; + end if; + else + if Line_Lst = L.Line_Nr then + Write_Empty_Bar_Line (Line_Size); + Write_Str (String'(1 .. REGION_OFFSET => ' ')); + Write_Str (Loc.Label.all); + Write_Eol; + end if; + end if; + + end Write_Span_Labels; + + ------------------- + -- Trimmed_Image -- + ------------------- + + function Trimmed_Image (I : Natural) return String is + Img_Raw : constant String := Natural'Image (I); + begin + return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); + end Trimmed_Image; + + ------------------------------- + -- Write_Intersecting_Labels -- + ------------------------------- + + procedure Write_Intersecting_Labels + (Intersecting_Labels : Labeled_Span_List) + is + Ls : Labeled_Span_Type; + Ls_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Intersecting_Labels); + Idx : Integer := 0; + begin + while Labeled_Span_Lists.Has_Next (Ls_It) loop + Labeled_Span_Lists.Next (Ls_It, Ls); + Idx := Idx + 1; + + Write_Empty_Bar_Line (MAX_BAR_POS); + Write_Str (" "); + Write_Int (Int (Idx)); + Write_Str (": "); + Write_Str (Ls.Label.all); + Write_Eol; + end loop; + end Write_Intersecting_Labels; + + ------------------------ + -- Write_File_Section -- + ------------------------ + + procedure Write_File_Section (Sec : File_Sections; + Write_File_Name : Boolean; + File_Name_Offset : Integer) + is + use Lines_Lists; + + L : Printable_Line; + L_It : Iterator := Iterate (Sec.Lines); + + -- The error should be included in the first (primary) span of the file. + Loc : constant Labeled_Span_Type := + Labeled_Span_Lists.First (Lines_Lists.First (Sec.Lines).Spans); + + Multiple_Labeled_Spans : Boolean := False; + + Idx : Integer := 0; + + Intersecting_Labels : constant Labeled_Span_List := + Labeled_Span_Lists.Create; + + Prev_Line_Nr : Natural := 0; + + Within_Region_Span : Boolean := False; + begin + if Write_File_Name then + + -- offset the file start location for sub-diagnostics + + Write_Str (String'(1 .. File_Name_Offset => ' ')); + Write_Str ("--> " & To_String (Loc.Span.Ptr)); + Write_Eol; + end if; + + while Has_Next (L_It) loop + Next (L_It, L); + declare + Line_Nr : constant Pos := L.Line_Nr; + Line_Str : constant String := Trimmed_Image (Natural (Line_Nr)); + + Line_Size : constant Integer := + Integer'Max (Line_Str'Length, MAX_BAR_POS); + + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (L.Spans); + + Buf : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (L.First)); + + Contains_Region_Span_Start : constant Boolean := + Has_Region_Span_Start (L); + Contains_Region_Span_End : constant Boolean := + Has_Region_Span_End (L); + begin + if not Multiple_Labeled_Spans then + Multiple_Labeled_Spans := Has_Multiple_Labeled_Spans (L); + end if; + + -- Write an empty line with the continuation symbol if the line + -- numbers are not contiguous + + if Prev_Line_Nr /= 0 + and then Pos (Prev_Line_Nr + 1) /= Line_Nr + then + Write_Empty_Skip_Line (Line_Size); + + if Within_Region_Span then + Write_Region_Continuation; + end if; + + Write_Eol; + end if; + + if Contains_Region_Span_Start then + Within_Region_Span := True; + end if; + + Write_Line_Marker (Line_Nr, Line_Size); + + -- Write either the region span symbol or the same number of + -- whitespaces. + + if Contains_Region_Span_Start or Contains_Region_Span_End then + Write_Region_Delimiter; + elsif Within_Region_Span then + Write_Region_Bar; + else + Write_Region_Offset; + end if; + + -- Write the line itself + + Write_Buffer + (Buf => Buf, + First => L.First, + Last => L.Last); + + -- Write all the spans for the line + + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + if Multiple_Labeled_Spans + and then Loc.Label /= null + then + + -- Collect all the spans with labels to print them at the + -- end. + + Labeled_Span_Lists.Append (Intersecting_Labels, Loc); + + Idx := Idx + 1; + + Write_Span_Labels (Loc, + L, + Line_Size, + Trimmed_Image (Idx), + Within_Region_Span); + else + Write_Span_Labels (Loc, + L, + Line_Size, + "", + Within_Region_Span); + end if; + + end loop; + + if Contains_Region_Span_End then + Within_Region_Span := False; + end if; + + Prev_Line_Nr := Natural (Line_Nr); + end; + end loop; + + Write_Intersecting_Labels (Intersecting_Labels); + end Write_File_Section; + + ------------------------- + -- Write_Labeled_Spans -- + ------------------------- + + procedure Write_Labeled_Spans (Spans : Labeled_Span_List; + Write_File_Name : Boolean; + File_Name_Offset : Integer) + is + Sections : File_Section_List := Create_File_Sections (Spans); + + Sec : File_Sections; + F_It : File_Section_Lists.Iterator := + File_Section_Lists.Iterate (Sections); + begin + while File_Section_Lists.Has_Next (F_It) loop + File_Section_Lists.Next (F_It, Sec); + + Write_File_Section + (Sec, Write_File_Name, File_Name_Offset); + end loop; + + File_Section_Lists.Destroy (Sections); + end Write_Labeled_Spans; + + -------------------------- + -- Write_Error_Msg_Line -- + -------------------------- + + procedure Write_Error_Msg_Line (Diag : Diagnostic_Type) is + Switch_Str : constant String := Get_Doc_Switch (Diag); + + Kind_Str : constant String := Kind_To_String (Diag); + + SGR_Code : constant String := + (if Kind_Str = "error" then SGR_Error + elsif Kind_Str = "warning" then SGR_Warning + elsif Kind_Str = "info" then SGR_Note + else SGR_Reset); + begin + Write_Str (SGR_Code); + + Write_Str ("[" & To_String (Diag.Id) & "]"); + + Write_Str (" " & Kind_To_String (Diag) & ": "); + + Write_Str (SGR_Reset); + + Write_Str (Diag.Message.all); + + if Switch_Str /= "" then + Write_Str (" " & Switch_Str); + end if; + + if Diag.Warn_Err then + Write_Str (" [warning-as-error]"); + end if; + + Write_Eol; + end Write_Error_Msg_Line; + + ---------------------------- + -- Should_Write_File_Name -- + ---------------------------- + + function Should_Write_File_Name (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + return Boolean + is + Sub_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Sub_Diag.Locations); + + Diag_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Diag.Locations); + + function Has_Multiple_Files (Spans : Labeled_Span_List) return Boolean; + + ------------------------ + -- Has_Multiple_Files -- + ------------------------ + + function Has_Multiple_Files + (Spans : Labeled_Span_List) return Boolean + is + First : constant Labeled_Span_Type := + Labeled_Span_Lists.First (Spans); + + File : constant String := To_File_Name (First.Span.Ptr); + + Loc : Labeled_Span_Type; + It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Spans); + + begin + while Labeled_Span_Lists.Has_Next (It) loop + Labeled_Span_Lists.Next (It, Loc); + + if To_File_Name (Loc.Span.Ptr) /= File then + return True; + end if; + end loop; + return False; + end Has_Multiple_Files; + begin + return + Has_Multiple_Files (Diag.Locations) + or else To_File_Name (Sub_Loc.Span.Ptr) /= + To_File_Name (Diag_Loc.Span.Ptr); + end Should_Write_File_Name; + + ------------------------ + -- Should_Write_Spans -- + ------------------------ + + function Should_Write_Spans (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type) + return Boolean + is + Sub_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Sub_Diag.Locations); + + Diag_Loc : constant Labeled_Span_Type := + Get_Primary_Labeled_Span (Diag.Locations); + begin + return Sub_Loc /= No_Labeled_Span + and then Diag_Loc /= No_Labeled_Span + and then Sub_Loc.Span.Ptr /= Diag_Loc.Span.Ptr; + end Should_Write_Spans; + + ---------------- + -- Print_Edit -- + ---------------- + + procedure Print_Edit (Edit : Edit_Type; Offset : Integer) is + Buf : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (Edit.Span.Ptr)); + + Line_Nr : constant Pos := Pos (Get_Physical_Line_Number (Edit.Span.Ptr)); + + Line_Fst : constant Source_Ptr := Get_Line_Start (Buf, Edit.Span.First); + Line_Lst : constant Source_Ptr := Get_Line_End (Buf, Edit.Span.First); + begin + Write_Str (String'(1 .. Offset => ' ')); + Write_Str ("--> " & To_File_Name (Edit.Span.Ptr)); + Write_Eol; + + -- write the original line + + Write_Char ('-'); + Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1); + + Write_Buffer + (Buf => Buf, + First => Line_Fst, + Last => Line_Lst); + + -- write the edited line + + Write_Char ('+'); + Write_Line_Marker (Line_Nr, MAX_BAR_POS - 1); + + Write_Buffer + (Buf => Buf, + First => Line_Fst, + Last => Edit.Span.First - 1); + + if Edit.Text /= null then + Write_Str (Edit.Text.all); + end if; + + Write_Buffer + (Buf => Buf, + First => Edit.Span.Last + 1, + Last => Line_Lst); + + end Print_Edit; + + --------------- + -- Print_Fix -- + --------------- + + procedure Print_Fix (Fix : Fix_Type; Offset : Integer) is + use Edit_Lists; + begin + Write_Str (String'(1 .. Offset => ' ')); + Write_Str ("+ Fix: "); + + if Fix.Description /= null then + Write_Str (Fix.Description.all); + end if; + Write_Eol; + + if Present (Fix.Edits) then + declare + Edit : Edit_Type; + + It : Iterator := Iterate (Fix.Edits); + begin + while Has_Next (It) loop + Next (It, Edit); + + Print_Edit (Edit, MAX_BAR_POS - 1); + end loop; + end; + end if; + end Print_Fix; + + -------------------------- + -- Print_Sub_Diagnostic -- + -------------------------- + + procedure Print_Sub_Diagnostic + (Sub_Diag : Sub_Diagnostic_Type; + Diag : Diagnostic_Type; + Offset : Integer) + is + begin + Write_Str (String'(1 .. Offset => ' ')); + + if Sub_Diag.Kind = Suggestion then + Write_Str ("+ Suggestion: "); + else + Write_Str ("+ "); + end if; + + Write_Str (Sub_Diag.Message.all); + Write_Eol; + + if Should_Write_Spans (Sub_Diag, Diag) then + Write_Labeled_Spans (Sub_Diag.Locations, + Should_Write_File_Name (Sub_Diag, Diag), + Offset); + end if; + end Print_Sub_Diagnostic; + + ---------------------- + -- Print_Diagnostic -- + ---------------------- + + procedure Print_Diagnostic (Diag : Diagnostic_Type) is + + begin + -- Print the main diagnostic + + Write_Error_Msg_Line (Diag); + + -- Print diagnostic locations along with spans + + Write_Labeled_Spans (Diag.Locations, True, 0); + + -- Print subdiagnostics + + if Sub_Diagnostic_Lists.Present (Diag.Sub_Diagnostics) then + declare + use Sub_Diagnostic_Lists; + Sub_Diag : Sub_Diagnostic_Type; + + It : Iterator := Iterate (Diag.Sub_Diagnostics); + begin + while Has_Next (It) loop + Next (It, Sub_Diag); + + -- Print the subdiagnostic and offset the location of the file + -- name + + Print_Sub_Diagnostic (Sub_Diag, Diag, MAX_BAR_POS - 1); + end loop; + end; + end if; + + -- Print fixes + + if Fix_Lists.Present (Diag.Fixes) then + declare + use Fix_Lists; + Fix : Fix_Type; + + It : Iterator := Iterate (Diag.Fixes); + begin + while Has_Next (It) loop + Next (It, Fix); + + Print_Fix (Fix, MAX_BAR_POS - 1); + end loop; + end; + end if; + + -- Separate main diagnostics with a blank line + + Write_Eol; + + end Print_Diagnostic; +end Diagnostics.Pretty_Emitter; diff --git a/gcc/ada/diagnostics-pretty_emitter.ads b/gcc/ada/diagnostics-pretty_emitter.ads new file mode 100644 index 0000000..5f46e34 --- /dev/null +++ b/gcc/ada/diagnostics-pretty_emitter.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . P R E T T Y _ E M I T T E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Pretty_Emitter is + procedure Print_Diagnostic (Diag : Diagnostic_Type); +end Diagnostics.Pretty_Emitter; diff --git a/gcc/ada/diagnostics-repository.adb b/gcc/ada/diagnostics-repository.adb new file mode 100644 index 0000000..dca38e9 --- /dev/null +++ b/gcc/ada/diagnostics-repository.adb @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . R E P O S I T O R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; +with Diagnostics.Utils; use Diagnostics.Utils; +with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; +with Output; use Output; + +package body Diagnostics.Repository is + + --------------------------------- + -- Print_Diagnostic_Repository -- + --------------------------------- + + procedure Print_Diagnostic_Repository is + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_Str ("""" & "Diagnostics" & """" & ": " & "["); + Begin_Block; + + -- Avoid printing the first switch, which is a placeholder + + for I in Diagnostic_Entries'First .. Diagnostic_Entries'Last loop + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("Id", To_String (I)); + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Human_Id /= null then + Write_String_Attribute ("Human_Id", + Diagnostic_Entries (I).Human_Id.all); + else + Write_String_Attribute ("Human_Id", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Status = Active then + Write_String_Attribute ("Status", "Active"); + else + Write_String_Attribute ("Status", "Deprecated"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Documentation /= null then + Write_String_Attribute ("Documentation", + Diagnostic_Entries (I).Documentation.all); + else + Write_String_Attribute ("Documentation", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Diagnostic_Entries (I).Switch /= No_Switch_Id then + Write_Char (','); + NL_And_Indent; + Write_String_Attribute + ("Switch", + Get_Switch (Diagnostic_Entries (I).Switch).Human_Id.all); + else + Write_String_Attribute ("Switch", "null"); + end if; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + Write_Eol; + end Print_Diagnostic_Repository; + +end Diagnostics.Repository; diff --git a/gcc/ada/diagnostics-repository.ads b/gcc/ada/diagnostics-repository.ads new file mode 100644 index 0000000..b070fda --- /dev/null +++ b/gcc/ada/diagnostics-repository.ads @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . R E P O S I T O R Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +package Diagnostics.Repository is + + type Diagnostics_Registry_Type is + array (Diagnostic_Id) of Diagnostic_Entry_Type; + + -- Include the diagnostic entries for every diagnostic id. + -- The entries should include: + -- * Whether the diagnostic with this id is active or not + -- * The human-readable name for the diagnostic for SARIF reports + -- * The switch id for the diagnostic if the diagnostic is linked to any + -- compiler switch + -- * The documentation file for the diagnostic written in the MD format. + -- The documentation file should include: + -- - The diagnostic id + -- - A short description of the diagnostic + -- - A minimal example of the code that triggers the diagnostic + -- - An explanation of why the diagnostic was triggered + -- - A suggestion on how to fix the issue + -- - Optionally additional information + -- TODO: the mandatory fields for the documentation file could be changed + + Diagnostic_Entries : Diagnostics_Registry_Type := + (No_Diagnostic_Id => (others => <>), + GNAT0001 => + (Status => Active, + Human_Id => new String'("Default_Iterator_Not_Primitive_Error"), + Documentation => new String'("./error_codes/GNAT0001.md"), + Switch => No_Switch_Id), + GNAT0002 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_For_Operator_Error"), + Documentation => new String'("./error_codes/GNAT0002.md"), + Switch => No_Switch_Id), + GNAT0003 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Left_To_Int_Error"), + Documentation => new String'("./error_codes/GNAT0003.md"), + Switch => No_Switch_Id), + GNAT0004 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Right_To_Int_Error"), + Documentation => new String'("./error_codes/GNAT0004.md"), + Switch => No_Switch_Id), + GNAT0005 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Left_Acc_Error"), + Documentation => new String'("./error_codes/GNAT0005.md"), + Switch => No_Switch_Id), + GNAT0006 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_Right_Acc_Error"), + Documentation => new String'("./error_codes/GNAT0006.md"), + Switch => No_Switch_Id), + GNAT0007 => + (Status => Active, + Human_Id => + new String'("Invalid_Operand_Types_General_Error"), + Documentation => new String'("./error_codes/GNAT0007.md"), + Switch => No_Switch_Id), + GNAT0008 => + (Status => Active, + Human_Id => + new String'("Pragma_No_Effect_With_Lock_Free_Warning"), + Documentation => new String'("./error_codes/GNAT0008.md"), + Switch => No_Switch_Id), + GNAT0009 => + (Status => Active, + Human_Id => new String'("End_Loop_Expected_Error"), + Documentation => new String'("./error_codes/GNAT0009.md"), + Switch => No_Switch_Id), + GNAT0010 => + (Status => Active, + Human_Id => new String'("Representation_Too_Late_Error"), + Documentation => new String'("./error_codes/GNAT0010.md"), + Switch => No_Switch_Id)); + + procedure Print_Diagnostic_Repository; + +end Diagnostics.Repository; diff --git a/gcc/ada/diagnostics-sarif_emitter.adb b/gcc/ada/diagnostics-sarif_emitter.adb new file mode 100644 index 0000000..cbb423b --- /dev/null +++ b/gcc/ada/diagnostics-sarif_emitter.adb @@ -0,0 +1,1090 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . S A R I F _ E M I T T E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Diagnostics.Utils; use Diagnostics.Utils; +with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; +with Gnatvsn; use Gnatvsn; +with Output; use Output; +with Sinput; use Sinput; + +package body Diagnostics.SARIF_Emitter is + + type Artifact_Change is record + File : String_Ptr; + -- Name of the file + + Replacements : Edit_List; + -- Regions of texts to be edited + end record; + + procedure Destroy (Elem : in out Artifact_Change); + pragma Inline (Destroy); + + function Equals (L, R : Artifact_Change) return Boolean is + (L.File /= null + and then R.File /= null + and then L.File.all = R.File.all); + + package Artifact_Change_Lists is new Doubly_Linked_Lists + (Element_Type => Artifact_Change, + "=" => Equals, + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Artifact_Change_List is Artifact_Change_Lists.Doubly_Linked_List; + + function Get_Artifact_Changes (Fix : Fix_Type) return Artifact_Change_List; + -- Group edits of a Fix into Artifact_Changes that organize the edits by + -- file name. + + function Get_Unique_Rules (Diags : Diagnostic_List) return Diagnostic_List; + -- Get a list of diagnostics that have unique Diagnostic Id-s. + + procedure Print_Replacement (Replacement : Edit_Type); + -- Print a replacement node + -- + -- { + -- deletedRegion: {<Region>}, + -- insertedContent: {<Message>} + -- } + + procedure Print_Fix (Fix : Fix_Type); + -- Print the fix node + -- + -- { + -- description: {<Message>}, + -- artifactChanges: [<ArtifactChange>] + -- } + + procedure Print_Fixes (Diag : Diagnostic_Type); + -- Print the fixes node + -- + -- "fixes": [ + -- <Fix>, + -- ... + -- ] + + procedure Print_Artifact_Change (A : Artifact_Change); + -- Print an ArtifactChange node + -- + -- { + -- artifactLocation: {<ArtifactLocation>}, + -- replacements: [<Replacements>] + -- } + + procedure Print_Artifact_Location (File_Name : String); + -- Print an artifactLocation node + -- + -- "artifactLocation": { + -- "URI": <File_Name> + -- } + + procedure Print_Location (Loc : Labeled_Span_Type; + Msg : String_Ptr); + -- Print a location node that consists of + -- * an optional message node + -- * a physicalLocation node + -- * ArtifactLocation node that consists of the file name + -- * Region node that consists of the start and end positions of the span + -- + -- { + -- "message": { + -- "text": <Msg> + -- }, + -- "physicalLocation": { + -- "artifactLocation": { + -- "URI": <File_Name (Loc)> + -- }, + -- "region": { + -- "startLine": <Line(Loc.Fst)>, + -- "startColumn": <Col(Loc.Fst)>, + -- "endLine": <Line(Loc.Lst)>, + -- "endColumn": Col(Loc.Lst)> + -- } + -- } + -- } + + procedure Print_Locations (Diag : Diagnostic_Type); + -- Print a locations node that consists of multiple location nodes. However + -- typically just one location for the primary span of the diagnostic. + -- + -- "locations": [ + -- <Location (Primary_Span (Diag))> + -- ], + + procedure Print_Message (Text : String; Name : String := "message"); + -- Print a SARIF message node + -- + -- "message": { + -- "text": <text> + -- }, + + procedure Print_Related_Locations (Diag : Diagnostic_Type); + -- Print a relatedLocations node that consists of multiple location nodes. + -- Related locations are the non-primary spans of the diagnostic and the + -- primary locations of sub-diagnostics. + -- + -- "relatedLocations": [ + -- <Location (Diag.Loc)> + -- ], + + procedure Print_Region (Start_Line : Int; + Start_Col : Int; + End_Line : Int; + End_Col : Int; + Name : String := "region"); + -- Print a region node. + -- + -- More specifically a text region node that specifies the textual + -- location of the region. Note that in SARIF there are also binary + -- regions. + -- + -- "<Name>": { + -- "startLine": Start_Line, + -- "startColumn": Start_Col, + -- "endLine": End_Line, + -- "endColumn": End_Col + 1 + -- } + -- + -- Note that there are many types of nodes that can have a region type, + -- but have a different node name. + -- + -- The end column is defined differently in the SARIF report than it is + -- for the spans within GNAT. Internally we consider the end column of a + -- span to be the last character of the span. + -- + -- However in SARIF the end column is defined as: + -- "The column number of the character following the end of the region" + -- + -- This method assumes that the End_Col passed to this procedure is using + -- the GNAT span definition and we amend the endColumn value so that it + -- matches the SARIF definition. + + procedure Print_Result (Diag : Diagnostic_Type); + -- { + -- "ruleId": <Diag.Id>, + -- "level": <Diag.Kind>, + -- "message": { + -- "text": <Diag.Message> + -- }, + -- "locations": [<Primary_Location>], + -- "relatedLocations": [<Secondary_Locations>] + -- }, + + procedure Print_Results (Diags : Diagnostic_List); + -- Print a results node that consists of multiple result nodes for each + -- diagnostic instance. + -- + -- "results": [ + -- <Result (Diag)> + -- ] + + procedure Print_Rule (Diag : Diagnostic_Type); + -- Print a rule node that consists of the following attributes: + -- * ruleId + -- * level + -- * name + -- + -- { + -- "id": <Diag.Id>, + -- "level": <Diag.Kind>, + -- "name": <Human_Id(Diag)> + -- }, + + procedure Print_Rules (Diags : Diagnostic_List); + -- Print a rules node that consists of multiple rule nodes. + -- Rules are considered to be a set of unique diagnostics with the unique + -- id-s. + -- + -- "rules": [ + -- <Rule (Diag)> + -- ] + + procedure Print_Runs (Diags : Diagnostic_List); + -- Print a runs node that can consist of multiple run nodes. + -- However for our report it consists of a single run that consists of + -- * a tool node + -- * a results node + -- + -- { + -- "tool": { <Tool (Diags)> }, + -- "results": [<Results (Diags)>] + -- } + + procedure Print_Tool (Diags : Diagnostic_List); + -- Print a tool node that consists of + -- * a driver node that consists of: + -- * name + -- * version + -- * rules + -- + -- "tool": { + -- "driver": { + -- "name": "GNAT", + -- "version": <GNAT_Version>, + -- "rules": [<Rules (Diags)>] + -- } + -- } + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Artifact_Change) + is + + begin + Free (Elem.File); + end Destroy; + + -------------------------- + -- Get_Artifact_Changes -- + -------------------------- + + function Get_Artifact_Changes (Fix : Fix_Type) return Artifact_Change_List + is + procedure Insert (Changes : Artifact_Change_List; E : Edit_Type); + + ------------ + -- Insert -- + ------------ + + procedure Insert (Changes : Artifact_Change_List; E : Edit_Type) + is + A : Artifact_Change; + + It : Artifact_Change_Lists.Iterator := + Artifact_Change_Lists.Iterate (Changes); + begin + while Artifact_Change_Lists.Has_Next (It) loop + Artifact_Change_Lists.Next (It, A); + + if A.File.all = To_File_Name (E.Span.Ptr) then + Edit_Lists.Append (A.Replacements, E); + return; + end if; + end loop; + + declare + Replacements : constant Edit_List := Edit_Lists.Create; + begin + Edit_Lists.Append (Replacements, E); + Artifact_Change_Lists.Append + (Changes, + (File => new String'(To_File_Name (E.Span.Ptr)), + Replacements => Replacements)); + end; + end Insert; + + Changes : constant Artifact_Change_List := Artifact_Change_Lists.Create; + + E : Edit_Type; + + It : Edit_Lists.Iterator := Edit_Lists.Iterate (Fix.Edits); + begin + while Edit_Lists.Has_Next (It) loop + Edit_Lists.Next (It, E); + + Insert (Changes, E); + end loop; + + return Changes; + end Get_Artifact_Changes; + + ---------------------- + -- Get_Unique_Rules -- + ---------------------- + + function Get_Unique_Rules (Diags : Diagnostic_List) + return Diagnostic_List + is + use Diagnostics.Diagnostics_Lists; + + procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type); + + ------------ + -- Insert -- + ------------ + + procedure Insert (Rules : Diagnostic_List; D : Diagnostic_Type) is + It : Iterator := Iterate (Rules); + R : Diagnostic_Type; + begin + while Has_Next (It) loop + Next (It, R); + + if R.Id = D.Id then + return; + elsif R.Id > D.Id then + Insert_Before (Rules, R, D); + return; + end if; + end loop; + + Append (Rules, D); + end Insert; + + D : Diagnostic_Type; + Unique_Rules : constant Diagnostic_List := Create; + + It : Iterator := Iterate (Diags); + begin + if Present (Diags) then + while Has_Next (It) loop + Next (It, D); + Insert (Unique_Rules, D); + end loop; + end if; + + return Unique_Rules; + end Get_Unique_Rules; + + --------------------------- + -- Print_Artifact_Change -- + --------------------------- + + procedure Print_Artifact_Change (A : Artifact_Change) + is + use Diagnostics.Edit_Lists; + E : Edit_Type; + E_It : Iterator; + + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print artifactLocation + + Print_Artifact_Location (A.File.all); + + Write_Char (','); + NL_And_Indent; + + Write_Str ("""" & "replacements" & """" & ": " & "["); + Begin_Block; + NL_And_Indent; + + E_It := Iterate (A.Replacements); + + while Has_Next (E_It) loop + Next (E_It, E); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Replacement (E); + end loop; + + -- End replacements + + End_Block; + NL_And_Indent; + Write_Char (']'); + + -- End artifactChange + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Artifact_Change; + + ----------------------------- + -- Print_Artifact_Location -- + ----------------------------- + + procedure Print_Artifact_Location (File_Name : String) is + + begin + Write_Str ("""" & "artifactLocation" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("uri", File_Name); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Artifact_Location; + + ----------------------- + -- Print_Replacement -- + ----------------------- + + procedure Print_Replacement (Replacement : Edit_Type) is + -- Span start positions + Fst : constant Source_Ptr := Replacement.Span.First; + Line_Fst : constant Int := Int (Get_Physical_Line_Number (Fst)); + Col_Fst : constant Int := Int (Get_Column_Number (Fst)); + + -- Span end positions + Lst : constant Source_Ptr := Replacement.Span.Last; + Line_Lst : constant Int := Int (Get_Physical_Line_Number (Lst)); + Col_Lst : constant Int := Int (Get_Column_Number (Lst)); + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print deletedRegion + + Print_Region (Start_Line => Line_Fst, + Start_Col => Col_Fst, + End_Line => Line_Lst, + End_Col => Col_Lst, + Name => "deletedRegion"); + + if Replacement.Text /= null then + Write_Char (','); + NL_And_Indent; + + Print_Message (Replacement.Text.all, "insertedContent"); + end if; + + -- End replacement + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Replacement; + + --------------- + -- Print_Fix -- + --------------- + + procedure Print_Fix (Fix : Fix_Type) is + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print the message if the location has one + + if Fix.Description /= null then + Print_Message (Fix.Description.all, "description"); + + Write_Char (','); + NL_And_Indent; + end if; + + declare + use Artifact_Change_Lists; + Changes : Artifact_Change_List := Get_Artifact_Changes (Fix); + A : Artifact_Change; + A_It : Iterator := Iterate (Changes); + begin + Write_Str ("""" & "artifactChanges" & """" & ": " & "["); + Begin_Block; + + while Has_Next (A_It) loop + Next (A_It, A); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + + Print_Artifact_Change (A); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + Destroy (Changes); + end; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Fix; + + ----------------- + -- Print_Fixes -- + ----------------- + + procedure Print_Fixes (Diag : Diagnostic_Type) is + use Diagnostics.Fix_Lists; + F : Fix_Type; + F_It : Iterator; + + First : Boolean := True; + begin + Write_Str ("""" & "fixes" & """" & ": " & "["); + Begin_Block; + + if Present (Diag.Fixes) then + F_It := Iterate (Diag.Fixes); + while Has_Next (F_It) loop + Next (F_It, F); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Fix (F); + end loop; + end if; + + End_Block; + NL_And_Indent; + Write_Char (']'); + end Print_Fixes; + + ------------------ + -- Print_Region -- + ------------------ + + procedure Print_Region (Start_Line : Int; + Start_Col : Int; + End_Line : Int; + End_Col : Int; + Name : String := "region") + is + + begin + Write_Str ("""" & Name & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + Write_Int_Attribute ("startLine", Start_Line); + Write_Char (','); + NL_And_Indent; + + Write_Int_Attribute ("startColumn", Start_Col); + Write_Char (','); + NL_And_Indent; + + Write_Int_Attribute ("endLine", End_Line); + Write_Char (','); + NL_And_Indent; + + -- Convert the end of the span to the definition of the endColumn + -- for a SARIF region. + + Write_Int_Attribute ("endColumn", End_Col + 1); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Region; + + -------------------- + -- Print_Location -- + -------------------- + + procedure Print_Location (Loc : Labeled_Span_Type; + Msg : String_Ptr) + is + + -- Span start positions + Fst : constant Source_Ptr := Loc.Span.First; + Line_Fst : constant Int := Int (Get_Physical_Line_Number (Fst)); + Col_Fst : constant Int := Int (Get_Column_Number (Fst)); + + -- Span end positions + Lst : constant Source_Ptr := Loc.Span.Last; + Line_Lst : constant Int := Int (Get_Physical_Line_Number (Lst)); + Col_Lst : constant Int := Int (Get_Column_Number (Lst)); + + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print the message if the location has one + + if Msg /= null then + Print_Message (Msg.all); + + Write_Char (','); + NL_And_Indent; + end if; + + Write_Str ("""" & "physicalLocation" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + -- Print artifactLocation + + Print_Artifact_Location (To_File_Name (Loc.Span.Ptr)); + + Write_Char (','); + NL_And_Indent; + + -- Print region + + Print_Region (Start_Line => Line_Fst, + Start_Col => Col_Fst, + End_Line => Line_Lst, + End_Col => Col_Lst); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Location; + + --------------------- + -- Print_Locations -- + --------------------- + + procedure Print_Locations (Diag : Diagnostic_Type) is + use Diagnostics.Labeled_Span_Lists; + Loc : Labeled_Span_Type; + It : Iterator := Iterate (Diag.Locations); + + First : Boolean := True; + begin + Write_Str ("""" & "locations" & """" & ": " & "["); + Begin_Block; + + while Has_Next (It) loop + Next (It, Loc); + + -- Only the primary span is considered as the main location other + -- spans are considered related locations + + if Loc.Is_Primary then + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Location (Loc, Loc.Label); + end if; + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + end Print_Locations; + + ------------------- + -- Print_Message -- + ------------------- + + procedure Print_Message (Text : String; Name : String := "message") is + + begin + Write_Str ("""" & Name & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + Write_String_Attribute ("text", Text); + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Message; + + ----------------------------- + -- Print_Related_Locations -- + ----------------------------- + + procedure Print_Related_Locations (Diag : Diagnostic_Type) is + Loc : Labeled_Span_Type; + Loc_It : Labeled_Span_Lists.Iterator := + Labeled_Span_Lists.Iterate (Diag.Locations); + + Sub : Sub_Diagnostic_Type; + Sub_It : Sub_Diagnostic_Lists.Iterator; + + First : Boolean := True; + begin + Write_Str ("""" & "relatedLocations" & """" & ": " & "["); + Begin_Block; + + -- Related locations are the non-primary spans of the diagnostic + + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + -- Non-primary spans are considered related locations + + if not Loc.Is_Primary then + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Location (Loc, Loc.Label); + end if; + end loop; + + -- And the sub-diagnostic locations + + if Sub_Diagnostic_Lists.Present (Diag.Sub_Diagnostics) then + Sub_It := Sub_Diagnostic_Lists.Iterate (Diag.Sub_Diagnostics); + + while Sub_Diagnostic_Lists.Has_Next (Sub_It) loop + Sub_Diagnostic_Lists.Next (Sub_It, Sub); + + declare + Found : Boolean := False; + + Prim_Loc : Labeled_Span_Type; + begin + if Labeled_Span_Lists.Present (Sub.Locations) then + Loc_It := Labeled_Span_Lists.Iterate (Sub.Locations); + while Labeled_Span_Lists.Has_Next (Loc_It) loop + Labeled_Span_Lists.Next (Loc_It, Loc); + + -- For sub-diagnostic locations, only the primary span is + -- considered. + + if not Found and then Loc.Is_Primary then + Found := True; + Prim_Loc := Loc; + end if; + end loop; + else + + -- If there are no locations for the sub-diagnostic then use + -- the primary location of the main diagnostic. + + Found := True; + Prim_Loc := Primary_Location (Diag); + end if; + + -- For mapping sub-diagnostics to related locations we have to + -- make some compromises in details. + -- + -- Firstly we only make one entry that is for the primary span + -- of the sub-diagnostic. + -- + -- Secondly this span can also have a label. However this + -- pattern is not advised and by default we include the message + -- of the sub-diagnostic as the message in location node since + -- it should have more information. + + if Found then + if First then + First := False; + else + Write_Char (','); + end if; + NL_And_Indent; + Print_Location (Prim_Loc, Sub.Message); + end if; + end; + end loop; + end if; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + end Print_Related_Locations; + + ------------------ + -- Print_Result -- + ------------------ + + procedure Print_Result (Diag : Diagnostic_Type) is + + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- Print ruleId + + Write_String_Attribute ("ruleId", "[" & To_String (Diag.Id) & "]"); + + Write_Char (','); + NL_And_Indent; + + -- Print level + + Write_String_Attribute ("level", Kind_To_String (Diag)); + + Write_Char (','); + NL_And_Indent; + + -- Print message + + Print_Message (Diag.Message.all); + + Write_Char (','); + NL_And_Indent; + + -- Print locations + + Print_Locations (Diag); + + Write_Char (','); + NL_And_Indent; + + -- Print related locations + + Print_Related_Locations (Diag); + + Write_Char (','); + NL_And_Indent; + + -- Print fixes + + Print_Fixes (Diag); + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + end Print_Result; + + ------------------- + -- Print_Results -- + ------------------- + + procedure Print_Results (Diags : Diagnostic_List) is + use Diagnostics.Diagnostics_Lists; + + D : Diagnostic_Type; + + It : Iterator := Iterate (All_Diagnostics); + + First : Boolean := True; + begin + Write_Str ("""" & "results" & """" & ": " & "["); + Begin_Block; + + if Present (Diags) then + while Has_Next (It) loop + Next (It, D); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Result (D); + end loop; + end if; + + End_Block; + NL_And_Indent; + Write_Char (']'); + end Print_Results; + + ---------------- + -- Print_Rule -- + ---------------- + + procedure Print_Rule (Diag : Diagnostic_Type) is + Human_Id : constant String_Ptr := Get_Human_Id (Diag); + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("id", "[" & To_String (Diag.Id) & "]"); + Write_Char (','); + NL_And_Indent; + + Write_String_Attribute ("level", Kind_To_String (Diag)); + Write_Char (','); + NL_And_Indent; + + if Human_Id = null then + Write_String_Attribute ("name", "Uncategorized_Diagnostic"); + else + Write_String_Attribute ("name", Human_Id.all); + end if; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end Print_Rule; + + ----------------- + -- Print_Rules -- + ----------------- + + procedure Print_Rules (Diags : Diagnostic_List) is + use Diagnostics.Diagnostics_Lists; + + R : Diagnostic_Type; + Rules : constant Diagnostic_List := Get_Unique_Rules (Diags); + + It : Iterator := Iterate (Rules); + + First : Boolean := True; + begin + Write_Str ("""" & "rules" & """" & ": " & "["); + Begin_Block; + + while Has_Next (It) loop + Next (It, R); + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + Print_Rule (R); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + end Print_Rules; + + ---------------- + -- Print_Tool -- + ---------------- + + procedure Print_Tool (Diags : Diagnostic_List) is + + begin + Write_Str ("""" & "tool" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + -- -- Attributes of tool + + Write_Str ("""" & "driver" & """" & ": " & "{"); + Begin_Block; + NL_And_Indent; + + -- Attributes of tool.driver + + Write_String_Attribute ("name", "GNAT"); + Write_Char (','); + NL_And_Indent; + + Write_String_Attribute ("version", Gnat_Version_String); + Write_Char (','); + NL_And_Indent; + + Print_Rules (Diags); + + -- End of tool.driver + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + + -- End of tool + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + end Print_Tool; + + ---------------- + -- Print_Runs -- + ---------------- + + procedure Print_Runs (Diags : Diagnostic_List) is + + begin + Write_Str ("""" & "runs" & """" & ": " & "["); + Begin_Block; + NL_And_Indent; + + -- Runs can consist of multiple "run"-s. However the GNAT SARIF report + -- only has one. + + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + -- A run consists of a tool + + Print_Tool (Diags); + + Write_Char (','); + NL_And_Indent; + + -- A run consists of results + + Print_Results (Diags); + + -- End of run + + End_Block; + NL_And_Indent; + + Write_Char ('}'); + + End_Block; + NL_And_Indent; + + -- End of runs + + Write_Char (']'); + end Print_Runs; + + ------------------------ + -- Print_SARIF_Report -- + ------------------------ + + procedure Print_SARIF_Report (Diags : Diagnostic_List) is + + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_String_Attribute ("version", "2.1.0"); + Write_Char (','); + NL_And_Indent; + + Print_Runs (Diags); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + Write_Eol; + end Print_SARIF_Report; + +end Diagnostics.SARIF_Emitter; diff --git a/gcc/ada/diagnostics-sarif_emitter.ads b/gcc/ada/diagnostics-sarif_emitter.ads new file mode 100644 index 0000000..3d9bbae --- /dev/null +++ b/gcc/ada/diagnostics-sarif_emitter.ads @@ -0,0 +1,29 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . S A R I F _ E M I T T E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.SARIF_Emitter is + + procedure Print_SARIF_Report (Diags : Diagnostic_List); +end Diagnostics.SARIF_Emitter; diff --git a/gcc/ada/diagnostics-switch_repository.adb b/gcc/ada/diagnostics-switch_repository.adb new file mode 100644 index 0000000..d609901 --- /dev/null +++ b/gcc/ada/diagnostics-switch_repository.adb @@ -0,0 +1,688 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . D I A G N O S T I C S _ R E P O S I T O R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils; +with Output; use Output; +package body Diagnostics.Switch_Repository is + + Switches : constant array (Switch_Id) + of Switch_Type := + (No_Switch_Id => + (others => <>), + gnatwb => + (Human_Id => new String'("Warn_On_Bad_Fixed_Value"), + Status => Active, + Short_Name => new String'("gnatwb"), + Description => null, + Documentation_Url => null), + gnatwc => + (Human_Id => new String'("Constant_Condition_Warnings"), + Status => Active, + Short_Name => new String'("gnatwc"), + Description => null, + Documentation_Url => null), + gnatwd => + -- TODO: is this a subcheck of general gnatwu? + (Human_Id => new String'("Warn_On_Dereference"), + Status => Active, + Short_Name => new String'("gnatwd"), + Description => null, + Documentation_Url => null), + gnatwf => + (Human_Id => new String'("Check_Unreferenced_Formals"), + Status => Active, + Short_Name => new String'("gnatwf"), + Description => null, + Documentation_Url => null), + gnatwg => + (Human_Id => new String'("Warn_On_Unrecognized_Pragma"), + Status => Active, + Short_Name => new String'("gnatwg"), + Description => null, + Documentation_Url => null), + gnatwh => + (Human_Id => new String'("Warn_On_Hiding"), + Status => Active, + Short_Name => new String'("gnatwh"), + Description => null, + Documentation_Url => null), + gnatwi => + (Human_Id => new String'("Implementation_Unit_Warnings"), + Status => Active, + Short_Name => new String'("gnatwi"), + Description => null, + Documentation_Url => null), + gnatwj => + (Human_Id => new String'("Warn_On_Obsolescent_Feature"), + Status => Active, + Short_Name => new String'("gnatwj"), + Description => null, + Documentation_Url => null), + gnatwk => + (Human_Id => new String'("Warn_On_Constant"), + Status => Active, + Short_Name => new String'("gnatwk"), + Description => null, + Documentation_Url => null), + gnatwl => + (Human_Id => new String'("Elab_Warnings"), + Status => Active, + Short_Name => new String'("gnatwl"), + Description => null, + Documentation_Url => null), + gnatwm => + (Human_Id => new String'("Warn_On_Modified_Unread"), + Status => Active, + Short_Name => new String'("gnatwm"), + Description => null, + Documentation_Url => null), + gnatwo => + (Human_Id => new String'("Address_Clause_Overlay_Warnings"), + Status => Active, + Short_Name => new String'("gnatwo"), + Description => null, + Documentation_Url => null), + gnatwp => + (Human_Id => new String'("Ineffective_Inline_Warnings"), + Status => Active, + Short_Name => new String'("gnatwp"), + Description => null, + Documentation_Url => null), + gnatwq => + (Human_Id => new String'("Warn_On_Questionable_Missing_Parens"), + Status => Active, + Short_Name => new String'("gnatwq"), + Description => null, + Documentation_Url => null), + gnatwr => + (Human_Id => new String'("Warn_On_Redundant_Constructs"), + Status => Active, + Short_Name => new String'("gnatwr"), + Description => null, + Documentation_Url => null), + gnatwt => + (Human_Id => new String'("Warn_On_Deleted_Code"), + Status => Active, + Short_Name => new String'("gnatwt"), + Description => null, + Documentation_Url => null), + gnatwu => + (Human_Id => new String'("Warn_On_Unused_Entities"), + Status => Active, + Short_Name => new String'("gnatwu"), + Description => null, + Documentation_Url => null), + gnatwv => + (Human_Id => new String'("Warn_On_No_Value_Assigned"), + Status => Active, + Short_Name => new String'("gnatwv"), + Description => null, + Documentation_Url => null), + gnatww => + (Human_Id => new String'("Warn_On_Assumed_Low_Bound"), + Status => Active, + Short_Name => new String'("gnatww"), + Description => null, + Documentation_Url => null), + gnatwx => + (Human_Id => new String'("Warn_On_Export_Import"), + Status => Active, + Short_Name => new String'("gnatwx"), + Description => null, + Documentation_Url => null), + gnatwy => + (Human_Id => new String'("Warn_On_Ada_Compatibility_Issues"), + Status => Active, + Short_Name => new String'("gnatwy"), + Description => null, + Documentation_Url => null), + gnatwz => + (Human_Id => new String'("Warn_On_Unchecked_Conversion"), + Status => Active, + Short_Name => new String'("gnatwz"), + Description => null, + Documentation_Url => null), + gnatw_dot_a => + (Human_Id => new String'("Warn_On_Assertion_Failure"), + Status => Active, + Short_Name => new String'("gnatw.a"), + Description => null, + Documentation_Url => null), + gnatw_dot_b => + (Human_Id => new String'("Warn_On_Biased_Representation"), + Status => Active, + Short_Name => new String'("gnatw.b"), + Description => null, + Documentation_Url => null), + gnatw_dot_c => + (Human_Id => new String'("Warn_On_Unrepped_Components"), + Status => Active, + Short_Name => new String'("gnatw.c"), + Description => null, + Documentation_Url => null), + gnatw_dot_f => + (Human_Id => new String'("Warn_On_Elab_Access"), + Status => Active, + Short_Name => new String'("gnatw.f"), + Description => null, + Documentation_Url => null), + gnatw_dot_h => + (Human_Id => new String'("Warn_On_Record_Holes"), + Status => Active, + Short_Name => new String'("gnatw.h"), + Description => null, + Documentation_Url => null), + gnatw_dot_i => + (Human_Id => new String'("Warn_On_Overlap"), + Status => Active, + Short_Name => new String'("gnatw.i"), + Description => null, + Documentation_Url => null), + gnatw_dot_j => + (Human_Id => new String'("Warn_On_Late_Primitives"), + Status => Active, + Short_Name => new String'("gnatw.j"), + Description => null, + Documentation_Url => null), + gnatw_dot_k => + (Human_Id => new String'("Warn_On_Standard_Redefinition"), + Status => Active, + Short_Name => new String'("gnatw.k"), + Description => null, + Documentation_Url => null), + gnatw_dot_l => + (Human_Id => new String'("List_Inherited_Aspects"), + Status => Active, + Short_Name => new String'("gnatw.l"), + Description => null, + Documentation_Url => null), + gnatw_dot_m => + (Human_Id => new String'("Warn_On_Suspicious_Modulus_Value"), + Status => Active, + Short_Name => new String'("gnatw.m"), + Description => null, + Documentation_Url => null), + gnatw_dot_n => + (Human_Id => new String'("Warn_On_Atomic_Synchronization"), + Status => Active, + Short_Name => new String'("gnatw.n"), + Description => null, + Documentation_Url => null), + gnatw_dot_o => + (Human_Id => new String'("Warn_On_All_Unread_Out_Parameters"), + Status => Active, + Short_Name => new String'("gnatw.o"), + Description => null, + Documentation_Url => null), + gnatw_dot_p => + (Human_Id => new String'("Warn_On_Parameter_Order"), + Status => Active, + Short_Name => new String'("gnatw.p"), + Description => null, + Documentation_Url => null), + gnatw_dot_q => + (Human_Id => new String'("Warn_On_Questionable_Layout"), + Status => Active, + Short_Name => new String'("gnatw.q"), + Description => null, + Documentation_Url => null), + gnatw_dot_r => + (Human_Id => new String'("Warn_On_Object_Renames_Function"), + Status => Active, + Short_Name => new String'("gnatw.r"), + Description => null, + Documentation_Url => null), + gnatw_dot_s => + (Human_Id => new String'("Warn_On_Overridden_Size"), + Status => Active, + Short_Name => new String'("gnatw.s"), + Description => null, + Documentation_Url => null), + gnatw_dot_t => + (Human_Id => new String'("Warn_On_Suspicious_Contract"), + Status => Active, + Short_Name => new String'("gnatw.t"), + Description => null, + Documentation_Url => null), + gnatw_dot_u => + (Human_Id => new String'("Warn_On_Unordered_Enumeration_Type"), + Status => Active, + Short_Name => new String'("gnatw.u"), + Description => null, + Documentation_Url => null), + gnatw_dot_v => + (Human_Id => new String'("Warn_On_Reverse_Bit_Order"), + Status => Active, + Short_Name => new String'("gnatw.v"), + Description => null, + Documentation_Url => null), + gnatw_dot_w => + (Human_Id => new String'("Warn_On_Warnings_Off"), + Status => Active, + Short_Name => new String'("gnatw.w"), + Description => null, + Documentation_Url => null), + gnatw_dot_x => + (Human_Id => + new String'("Warn_No_Exception_Propagation_Active"), + Status => Active, + Short_Name => new String'("gnatw.x"), + Description => null, + Documentation_Url => null), + gnatw_dot_y => + (Human_Id => new String'("List_Body_Required_Info"), + Status => Active, + Short_Name => new String'("gnatw.y"), + Description => null, + Documentation_Url => null), + gnatw_dot_z => + (Human_Id => new String'("Warn_On_Size_Alignment"), + Status => Active, + Short_Name => new String'("gnatw.z"), + Description => null, + Documentation_Url => null), + gnatw_underscore_a => + (Human_Id => new String'("Warn_On_Anonymous_Allocators"), + Status => Active, + Short_Name => new String'("gnatw_a"), + Description => null, + Documentation_Url => null), + gnatw_underscore_c => + (Human_Id => new String'("Warn_On_Unknown_Compile_Time_Warning"), + Status => Active, + Short_Name => new String'("gnatw_c"), + Description => null, + Documentation_Url => null), + gnatw_underscore_j => + (Human_Id => new String'("Warn_On_Non_Dispatching_Primitives"), + Status => Active, + Short_Name => new String'("gnatw_j"), + Description => null, + Documentation_Url => null), + gnatw_underscore_l => + (Human_Id => new String'("Warn_On_Inherently_Limited_Types"), + Status => Active, + Short_Name => new String'("gnatw_l"), + Description => null, + Documentation_Url => null), + gnatw_underscore_p => + (Human_Id => new String'("Warn_On_Pedantic_Checks"), + Status => Active, + Short_Name => new String'("gnatw_p"), + Description => null, + Documentation_Url => null), + gnatw_underscore_q => + (Human_Id => new String'("Warn_On_Ignored_Equality"), + Status => Active, + Short_Name => new String'("gnatw_q"), + Description => null, + Documentation_Url => null), + gnatw_underscore_r => + (Human_Id => new String'("Warn_On_Component_Order"), + Status => Active, + Short_Name => new String'("gnatw_r"), + Description => null, + Documentation_Url => null), + gnatw_underscore_s => + (Human_Id => new String'("Warn_On_Ineffective_Predicate_Test"), + Status => Active, + Short_Name => new String'("gnatw_s"), + Description => null, + Documentation_Url => null), + -- NOTE: this flag is usually followed by a number specfifying the + -- indentation level. We encode all of these warnings as -gnaty0 + -- irregardless of the actual numeric value. + gnaty => + (Human_Id => new String'("Style_Check_Indentation_Level"), + Status => Active, + Short_Name => new String'("gnaty0"), + Description => null, + Documentation_Url => null), + gnatya => + (Human_Id => new String'("Style_Check_Attribute_Casing"), + Status => Active, + Short_Name => new String'("gnatya"), + Description => null, + Documentation_Url => null), + gnatyaa => + (Human_Id => new String'("Address_Clause_Overlay_Warnings"), + Status => Active, + Short_Name => new String'("gnatyA"), + Description => null, + Documentation_Url => null), + gnatyb => + (Human_Id => new String'("Style_Check_Blanks_At_End"), + Status => Active, + Short_Name => new String'("gnatyb"), + Description => null, + Documentation_Url => null), + gnatybb => + -- NOTE: in live documentation it is called "Check Boolean operators" + (Human_Id => new String'("Style_Check_Boolean_And_Or"), + Status => Active, + Short_Name => new String'("gnatyB"), + Description => null, + Documentation_Url => null), + gnatyc => + (Human_Id => new String'("Style_Check_Comments_Double_Space"), + Status => Active, + Short_Name => new String'("gnatyc"), + Description => null, + Documentation_Url => null), + gnatycc => + (Human_Id => new String'("Style_Check_Comments_Single_Space"), + Status => Active, + Short_Name => new String'("gnatyC"), + Description => null, + Documentation_Url => null), + gnatyd => + (Human_Id => new String'("Style_Check_DOS_Line_Terminator"), + Status => Active, + Short_Name => new String'("gnatyd"), + Description => null, + Documentation_Url => null), + gnatydd => + (Human_Id => new String'("Style_Check_Mixed_Case_Decls"), + Status => Active, + Short_Name => new String'("gnatyD"), + Description => null, + Documentation_Url => null), + gnatye => + (Human_Id => new String'("Style_Check_End_Labels"), + Status => Active, + Short_Name => new String'("gnatye"), + Description => null, + Documentation_Url => null), + gnatyf => + (Human_Id => new String'("Style_Check_Form_Feeds"), + Status => Active, + Short_Name => new String'("gnatyf"), + Description => null, + Documentation_Url => null), + gnatyh => + (Human_Id => new String'("Style_Check_Horizontal_Tabs"), + Status => Active, + Short_Name => new String'("gnatyh"), + Description => null, + Documentation_Url => null), + gnatyi => + (Human_Id => new String'("Style_Check_If_Then_Layout"), + Status => Active, + Short_Name => new String'("gnatyi"), + Description => null, + Documentation_Url => null), + gnatyii => + (Human_Id => new String'("Style_Check_Mode_In"), + Status => Active, + Short_Name => new String'("gnatyI"), + Description => null, + Documentation_Url => null), + gnatyk => + (Human_Id => new String'("Style_Check_Keyword_Casing"), + Status => Active, + Short_Name => new String'("gnatyk"), + Description => null, + Documentation_Url => null), + gnatyl => + (Human_Id => new String'("Style_Check_Layout"), + Status => Active, + Short_Name => new String'("gnatyl"), + Description => null, + Documentation_Url => null), + gnatyll => + (Human_Id => new String'("Style_Check_Max_Nesting_Level"), + Status => Active, + Short_Name => new String'("gnatyL"), + Description => null, + Documentation_Url => null), + gnatym => + (Human_Id => new String'("Style_Check_Max_Line_Length"), + Status => Active, + Short_Name => new String'("gnatym"), + Description => null, + Documentation_Url => null), + gnatymm => + -- TODO: May contain line length + (Human_Id => new String'("Style_Check_Max_Line_Length"), + Status => Active, + Short_Name => new String'("gnatyM"), + Description => null, + Documentation_Url => null), + gnatyn => + (Human_Id => new String'("Style_Check_Standard"), + Status => Active, + Short_Name => new String'("gnatyn"), + Description => null, + Documentation_Url => null), + gnatyo => + (Human_Id => new String'("Style_Check_Order_Subprograms"), + Status => Active, + Short_Name => new String'("gnatyo"), + Description => null, + Documentation_Url => null), + gnatyoo => + (Human_Id => new String'("Style_Check_Missing_Overriding"), + Status => Active, + Short_Name => new String'("gnatyO"), + Description => null, + Documentation_Url => null), + gnatyp => + (Human_Id => new String'("Style_Check_Pragma_Casing"), + Status => Active, + Short_Name => new String'("gnatyp"), + Description => null, + Documentation_Url => null), + gnatyr => + (Human_Id => new String'("Style_Check_References"), + Status => Active, + Short_Name => new String'("gnatyr"), + Description => null, + Documentation_Url => null), + gnatys => + (Human_Id => new String'("Style_Check_Specs"), + Status => Active, + Short_Name => new String'("gnatys"), + Description => null, + Documentation_Url => null), + gnatyss => + (Human_Id => new String'("Style_Check_Separate_Stmt_Lines"), + Status => Active, + Short_Name => new String'("gnatyS"), + Description => null, + Documentation_Url => null), + gnatytt => + (Human_Id => new String'("Style_Check_Tokens"), + Status => Active, + Short_Name => new String'("gnatyt"), + Description => null, + Documentation_Url => null), + gnatyu => + (Human_Id => new String'("Style_Check_Blank_Lines"), + Status => Active, + Short_Name => new String'("gnatyu"), + Description => null, + Documentation_Url => null), + gnatyx => + (Human_Id => new String'("Style_Check_Xtra_Parens"), + Status => Active, + Short_Name => new String'("gnatyx"), + Description => null, + Documentation_Url => null), + gnatyz => + (Human_Id => new String'("Style_Check_Xtra_Parens_Precedence"), + Status => Active, + Short_Name => new String'("gnatyz"), + Description => null, + Documentation_Url => null), + gnatel => + (Human_Id => new String'("Display_Elaboration_Messages"), + Status => Active, + Short_Name => new String'("gnatel"), + Description => null, + Documentation_Url => null) + ); + + ---------------- + -- Get_Switch -- + ---------------- + + function Get_Switch (Id : Switch_Id) return Switch_Type is + + begin + return Switches (Id); + end Get_Switch; + + function Get_Switch (Diag : Diagnostic_Type) return Switch_Type is + + begin + return Get_Switch (Diag.Switch); + end Get_Switch; + + ------------------- + -- Get_Switch_Id -- + ------------------- + + function Get_Switch_Id (Name : String) return Switch_Id is + Trimmed_Name : constant String := + (if Name (Name'Last) = ' ' then Name (Name'First .. Name'Last - 1) + else Name); + begin + for I in Active_Switch_Id loop + if Switches (I).Short_Name.all = Trimmed_Name then + return I; + end if; + end loop; + + return No_Switch_Id; + end Get_Switch_Id; + + ------------------- + -- Get_Switch_Id -- + ------------------- + + function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is + + begin + if E.Warn_Chr = "$ " then + return Get_Switch_Id ("gnatel"); + elsif E.Warn or E.Info then + return Get_Switch_Id ("gnatw" & E.Warn_Chr); + elsif E.Style then + return Get_Switch_Id ("gnaty" & E.Warn_Chr); + else + return No_Switch_Id; + end if; + end Get_Switch_Id; + + ----------------------------- + -- Print_Switch_Repository -- + ----------------------------- + + procedure Print_Switch_Repository is + First : Boolean := True; + begin + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + Write_Str ("""" & "Switches" & """" & ": " & "["); + Begin_Block; + + -- Avoid printing the first switch, which is a placeholder + + for I in Active_Switch_Id loop + + if First then + First := False; + else + Write_Char (','); + end if; + + NL_And_Indent; + + Write_Char ('{'); + Begin_Block; + NL_And_Indent; + + if Switches (I).Human_Id /= null then + Write_String_Attribute ("Human_Id", Switches (I).Human_Id.all); + else + Write_String_Attribute ("Human_Id", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Short_Name /= null then + Write_String_Attribute ("Short_Name", Switches (I).Short_Name.all); + else + Write_String_Attribute ("Short_Name", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Status = Active then + Write_String_Attribute ("Status", "Active"); + else + Write_String_Attribute ("Status", "Deprecated"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Description /= null then + Write_String_Attribute ("Description", + Switches (I).Description.all); + else + Write_String_Attribute ("Description", "null"); + end if; + + Write_Char (','); + NL_And_Indent; + + if Switches (I).Description /= null then + Write_String_Attribute ("Documentation_Url", + Switches (I).Description.all); + else + Write_String_Attribute ("Documentation_Url", "null"); + end if; + + End_Block; + NL_And_Indent; + Write_Char ('}'); + end loop; + + End_Block; + NL_And_Indent; + Write_Char (']'); + + End_Block; + NL_And_Indent; + Write_Char ('}'); + + Write_Eol; + end Print_Switch_Repository; + +end Diagnostics.Switch_Repository; diff --git a/gcc/ada/diagnostics-switch_repository.ads b/gcc/ada/diagnostics-switch_repository.ads new file mode 100644 index 0000000..5bd2d51 --- /dev/null +++ b/gcc/ada/diagnostics-switch_repository.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . D I A G N O S T I C S _ R E P O S I T O R Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ +with Erroutc; use Erroutc; + +package Diagnostics.Switch_Repository is + + function Get_Switch (Id : Switch_Id) return Switch_Type; + + function Get_Switch (Diag : Diagnostic_Type) return Switch_Type; + + function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id; + + function Get_Switch_Id (Name : String) return Switch_Id; + + procedure Print_Switch_Repository; + +end Diagnostics.Switch_Repository; diff --git a/gcc/ada/diagnostics-utils.adb b/gcc/ada/diagnostics-utils.adb new file mode 100644 index 0000000..3203e63 --- /dev/null +++ b/gcc/ada/diagnostics-utils.adb @@ -0,0 +1,358 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . U T I L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Diagnostics.Repository; use Diagnostics.Repository; +with Diagnostics.Switch_Repository; use Diagnostics.Switch_Repository; +with Errout; use Errout; +with Erroutc; use Erroutc; +with Namet; use Namet; +with Opt; use Opt; +with Sinput; use Sinput; +with Sinfo.Nodes; use Sinfo.Nodes; +with Warnsw; use Warnsw; + +package body Diagnostics.Utils is + + ------------------ + -- Get_Human_Id -- + ------------------ + + function Get_Human_Id (D : Diagnostic_Type) return String_Ptr is + begin + if D.Switch = No_Switch_Id then + return Diagnostic_Entries (D.Id).Human_Id; + else + return Get_Switch (D).Human_Id; + end if; + end Get_Human_Id; + + ------------------ + -- To_File_Name -- + ------------------ + + function To_File_Name (Sptr : Source_Ptr) return String is + Sfile : constant Source_File_Index := Get_Source_File_Index (Sptr); + Ref_Name : constant File_Name_Type := + (if Full_Path_Name_For_Brief_Errors then Full_Ref_Name (Sfile) + else Reference_Name (Sfile)); + + begin + return Get_Name_String (Ref_Name); + end To_File_Name; + + -------------------- + -- Line_To_String -- + -------------------- + + function Line_To_String (Sptr : Source_Ptr) return String is + Line : constant Logical_Line_Number := Get_Logical_Line_Number (Sptr); + Img_Raw : constant String := Int'Image (Int (Line)); + + begin + return Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); + end Line_To_String; + + ---------------------- + -- Column_To_String -- + ---------------------- + + function Column_To_String (Sptr : Source_Ptr) return String is + Col : constant Column_Number := Get_Column_Number (Sptr); + Img_Raw : constant String := Int'Image (Int (Col)); + + begin + return + (if Col < 10 then "0" else "") + & Img_Raw (Img_Raw'First + 1 .. Img_Raw'Last); + end Column_To_String; + + --------------- + -- To_String -- + --------------- + + function To_String (Sptr : Source_Ptr) return String is + begin + return + To_File_Name (Sptr) & ":" & Line_To_String (Sptr) & ":" + & Column_To_String (Sptr); + end To_String; + + -------------------- + -- Sloc_To_String -- + -------------------- + + function Sloc_To_String + (N : Node_Or_Entity_Id; Ref : Source_Ptr) return String + is + + begin + return Sloc_To_String (Sloc (N), Ref); + end Sloc_To_String; + + -------------------- + -- Sloc_To_String -- + -------------------- + + function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String + is + + begin + if Sptr = No_Location then + return "at unknown location"; + + elsif Sptr = System_Location then + return "in package System"; + + elsif Sptr = Standard_Location then + return "in package Standard"; + + elsif Sptr = Standard_ASCII_Location then + return "in package Standard.ASCII"; + + else + if Full_File_Name (Get_Source_File_Index (Sptr)) + /= Full_File_Name (Get_Source_File_Index (Ref)) + then + return "at " & To_String (Sptr); + else + return "at line " & Line_To_String (Sptr); + end if; + end if; + end Sloc_To_String; + + ------------------ + -- To_Full_Span -- + ------------------ + + function To_Full_Span (N : Node_Id) return Source_Span + is + Fst, Lst : Node_Id; + begin + First_And_Last_Nodes (N, Fst, Lst); + return To_Span (Ptr => Sloc (N), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst)); + end To_Full_Span; + + --------------- + -- To_String -- + --------------- + + function To_String (Id : Diagnostic_Id) return String is + begin + if Id = No_Diagnostic_Id then + return "GNAT0000"; + else + return Id'Img; + end if; + end To_String; + + ------------- + -- To_Name -- + ------------- + + function To_Name (E : Entity_Id) return String is + begin + -- The name of the node operator "&" has many special cases. Reuse the + -- node to name conversion implementation from the errout package for + -- now. + + Error_Msg_Node_1 := E; + Set_Msg_Text ("&", Sloc (E)); + + return Msg_Buffer (1 .. Msglen); + end To_Name; + + ------------------ + -- To_Type_Name -- + ------------------ + + function To_Type_Name (E : Entity_Id) return String is + begin + Error_Msg_Node_1 := E; + Set_Msg_Text ("}", Sloc (E)); + + return Msg_Buffer (1 .. Msglen); + end To_Type_Name; + + -------------------- + -- Kind_To_String -- + -------------------- + + function Kind_To_String + (D : Sub_Diagnostic_Type; + Parent : Diagnostic_Type) return String + is + (case D.Kind is + when Continuation => Kind_To_String (Parent), + when Help => "help", + when Note => "note", + when Suggestion => "suggestion"); + + -------------------- + -- Kind_To_String -- + -------------------- + + function Kind_To_String (D : Diagnostic_Type) return String is + (if D.Warn_Err then "error" + else + (case D.Kind is + when Diagnostics.Error => "error", + when Warning | Restriction_Warning | Default_Warning | + Tagless_Warning => "warning", + when Style => "style", + when Info | Info_Warning => "info")); + + ------------------------------ + -- Get_Primary_Labeled_Span -- + ------------------------------ + + function Get_Primary_Labeled_Span (Spans : Labeled_Span_List) + return Labeled_Span_Type + is + use Labeled_Span_Lists; + + S : Labeled_Span_Type; + It : Iterator; + begin + if Present (Spans) then + It := Iterate (Spans); + while Has_Next (It) loop + Next (It, S); + if S.Is_Primary then + return S; + end if; + end loop; + end if; + + return No_Labeled_Span; + end Get_Primary_Labeled_Span; + + -------------------- + -- Get_Doc_Switch -- + -------------------- + + function Get_Doc_Switch (Diag : Diagnostic_Type) return String is + begin + if Warning_Doc_Switch + and then Diag.Kind in Default_Warning + | Info + | Info_Warning + | Restriction_Warning + | Style + | Warning + then + if Diag.Switch = No_Switch_Id then + if Diag.Kind = Restriction_Warning then + return "[restriction warning]"; + + -- Info messages can have a switch tag but they should not have + -- a default switch tag. + + elsif Diag.Kind /= Info then + + -- For Default_Warning and Info_Warning + + return "[enabled by default]"; + end if; + else + declare + S : constant Switch_Type := Get_Switch (Diag); + begin + return "[-" & S.Short_Name.all & "]"; + end; + end if; + end if; + + return ""; + end Get_Doc_Switch; + + -------------------- + -- Appears_Before -- + -------------------- + + function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean is + + begin + return Appears_Before (Primary_Location (D1).Span.Ptr, + Primary_Location (D2).Span.Ptr); + end Appears_Before; + + -------------------- + -- Appears_Before -- + -------------------- + + function Appears_Before (P1, P2 : Source_Ptr) return Boolean is + + begin + if Get_Source_File_Index (P1) = Get_Source_File_Index (P2) then + if Get_Logical_Line_Number (P1) = Get_Logical_Line_Number (P2) then + return Get_Column_Number (P1) < Get_Column_Number (P2); + else + return Get_Logical_Line_Number (P1) < Get_Logical_Line_Number (P2); + end if; + else + return Get_Source_File_Index (P1) < Get_Source_File_Index (P2); + end if; + end Appears_Before; + + ------------------------------ + -- Insert_Based_On_Location -- + ------------------------------ + + procedure Insert_Based_On_Location + (List : Diagnostic_List; + Diagnostic : Diagnostic_Type) + is + use Diagnostics_Lists; + + It : Iterator := Iterate (List); + D : Diagnostic_Type; + begin + -- This is the common scenario where the error is reported at the + -- natural order the tree is processed. This saves a lot of time when + -- looking for the correct position in the list when there are a lot of + -- diagnostics. + + if Present (List) and then + not Is_Empty (List) and then + Appears_Before (Last (List), Diagnostic) + then + Append (List, Diagnostic); + else + while Has_Next (It) loop + Next (It, D); + + if Appears_Before (Diagnostic, D) then + Insert_Before (List, D, Diagnostic); + return; + end if; + end loop; + + Append (List, Diagnostic); + end if; + end Insert_Based_On_Location; + +end Diagnostics.Utils; diff --git a/gcc/ada/diagnostics-utils.ads b/gcc/ada/diagnostics-utils.ads new file mode 100644 index 0000000..caf01ab --- /dev/null +++ b/gcc/ada/diagnostics-utils.ads @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S . U T I L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Diagnostics.Utils is + + function Get_Human_Id (D : Diagnostic_Type) return String_Ptr; + + function Sloc_To_String (Sptr : Source_Ptr; Ref : Source_Ptr) return String; + -- Convert the source pointer to a string and prefix it with the correct + -- preposition. + -- + -- * If the location is in one of the standard locations, + -- then it yields "in package <LOCATION>". The explicit standard + -- locations are: + -- * System + -- * Standard + -- * Standard.ASCII + -- * if the location is missing the the sloc yields "at unknown location" + -- * if the location is in the same file as the current file, + -- then it yields "at line <line>". + -- * Otherwise sloc yields "at <file>:<line>:<column>" + + function Sloc_To_String (N : Node_Or_Entity_Id; + Ref : Source_Ptr) + return String; + -- Converts the Sloc of the node or entity to a Sloc string. + + function To_String (Sptr : Source_Ptr) return String; + -- Convert the source pointer to a string of the form: "file:line:column" + + function To_File_Name (Sptr : Source_Ptr) return String; + -- Converts the file name of the Sptr to a string. + + function Line_To_String (Sptr : Source_Ptr) return String; + -- Converts the logical line number of the Sptr to a string. + + function Column_To_String (Sptr : Source_Ptr) return String; + -- Converts the column number of the Sptr to a string. Column values less + -- than 10 are prefixed with a 0. + + function To_Full_Span (N : Node_Id) return Source_Span; + + function To_String (Id : Diagnostic_Id) return String; + -- Convert the diagnostic ID to a 4 character string padded with 0-s. + + function To_Name (E : Entity_Id) return String; + + function To_Type_Name (E : Entity_Id) return String; + + function Kind_To_String (D : Diagnostic_Type) return String; + + function Kind_To_String + (D : Sub_Diagnostic_Type; + Parent : Diagnostic_Type) return String; + + function Get_Primary_Labeled_Span (Spans : Labeled_Span_List) + return Labeled_Span_Type; + + function Get_Doc_Switch (Diag : Diagnostic_Type) return String; + + function Appears_Before (D1, D2 : Diagnostic_Type) return Boolean; + + function Appears_Before (P1, P2 : Source_Ptr) return Boolean; + + procedure Insert_Based_On_Location + (List : Diagnostic_List; + Diagnostic : Diagnostic_Type); + +end Diagnostics.Utils; diff --git a/gcc/ada/diagnostics.adb b/gcc/ada/diagnostics.adb new file mode 100644 index 0000000..8acc915 --- /dev/null +++ b/gcc/ada/diagnostics.adb @@ -0,0 +1,542 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Diagnostics.Brief_Emitter; +with Diagnostics.Pretty_Emitter; +with Diagnostics.Repository; use Diagnostics.Repository; +with Diagnostics.Utils; use Diagnostics.Utils; +with Lib; use Lib; +with Opt; use Opt; +with Sinput; use Sinput; +with Warnsw; + +package body Diagnostics is + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Labeled_Span_Type) is + begin + Free (Elem.Label); + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Sub_Diagnostic_Type) is + begin + Free (Elem.Message); + if Labeled_Span_Lists.Present (Elem.Locations) then + Labeled_Span_Lists.Destroy (Elem.Locations); + end if; + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Edit_Type) is + begin + Free (Elem.Text); + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Fix_Type) is + begin + Free (Elem.Description); + if Edit_Lists.Present (Elem.Edits) then + Edit_Lists.Destroy (Elem.Edits); + end if; + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (Elem : in out Diagnostic_Type) is + begin + Free (Elem.Message); + if Labeled_Span_Lists.Present (Elem.Locations) then + Labeled_Span_Lists.Destroy (Elem.Locations); + end if; + if Sub_Diagnostic_Lists.Present (Elem.Sub_Diagnostics) then + Sub_Diagnostic_Lists.Destroy (Elem.Sub_Diagnostics); + end if; + if Fix_Lists.Present (Elem.Fixes) then + Fix_Lists.Destroy (Elem.Fixes); + end if; + end Destroy; + + ------------------ + -- Add_Location -- + ------------------ + + procedure Add_Location + (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type) + is + use Labeled_Span_Lists; + begin + if not Present (Diagnostic.Locations) then + Diagnostic.Locations := Create; + end if; + + Append (Diagnostic.Locations, Location); + end Add_Location; + + ---------------------- + -- Primary_Location -- + ---------------------- + + function Primary_Location + (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type + is + use Labeled_Span_Lists; + Loc : Labeled_Span_Type; + + It : Iterator := Iterate (Diagnostic.Locations); + begin + while Has_Next (It) loop + Next (It, Loc); + if Loc.Is_Primary then + return Loc; + end if; + end loop; + + return (others => <>); + end Primary_Location; + + ------------------ + -- Add_Location -- + ------------------ + + procedure Add_Location + (Diagnostic : in out Diagnostic_Type; Location : Labeled_Span_Type) + is + use Labeled_Span_Lists; + begin + if not Present (Diagnostic.Locations) then + Diagnostic.Locations := Create; + end if; + + Append (Diagnostic.Locations, Location); + end Add_Location; + + ------------------------ + -- Add_Sub_Diagnostic -- + ------------------------ + + procedure Add_Sub_Diagnostic + (Diagnostic : in out Diagnostic_Type; + Sub_Diagnostic : Sub_Diagnostic_Type) + is + use Sub_Diagnostic_Lists; + begin + if not Present (Diagnostic.Sub_Diagnostics) then + Diagnostic.Sub_Diagnostics := Create; + end if; + + Append (Diagnostic.Sub_Diagnostics, Sub_Diagnostic); + end Add_Sub_Diagnostic; + + procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type) is + use Edit_Lists; + begin + if not Present (Fix.Edits) then + Fix.Edits := Create; + end if; + + Append (Fix.Edits, Edit); + end Add_Edit; + + ------------- + -- Add_Fix -- + ------------- + + procedure Add_Fix (Diagnostic : in out Diagnostic_Type; Fix : Fix_Type) is + use Fix_Lists; + begin + if not Present (Diagnostic.Fixes) then + Diagnostic.Fixes := Create; + end if; + + Append (Diagnostic.Fixes, Fix); + end Add_Fix; + + ----------------------- + -- Record_Diagnostic -- + ----------------------- + + procedure Record_Diagnostic (Diagnostic : Diagnostic_Type; + Update_Count : Boolean := True) + is + + procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type); + + ----------------------------- + -- Update_Diagnostic_Count -- + ----------------------------- + + procedure Update_Diagnostic_Count (Diagnostic : Diagnostic_Type) is + + begin + if Diagnostic.Kind = Error then + Total_Errors_Detected := Total_Errors_Detected + 1; + + if Diagnostic.Serious then + Serious_Errors_Detected := Serious_Errors_Detected + 1; + end if; + elsif Diagnostic.Kind in Warning | Style then + Warnings_Detected := Warnings_Detected + 1; + + if Diagnostic.Warn_Err then + Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; + end if; + elsif Diagnostic.Kind in Info then + Info_Messages := Info_Messages + 1; + end if; + end Update_Diagnostic_Count; + + procedure Handle_Serious_Error; + -- Internal procedure to do all error message handling for a serious + -- error message, other than bumping the error counts and arranging + -- for the message to be output. + + procedure Handle_Serious_Error is + begin + -- Turn off code generation if not done already + + if Operating_Mode = Generate_Code then + Operating_Mode := Check_Semantics; + Expander_Active := False; + end if; + + -- Set the fatal error flag in the unit table unless we are in + -- Try_Semantics mode (in which case we set ignored mode if not + -- currently set. This stops the semantics from being performed + -- if we find a serious error. This is skipped if we are currently + -- dealing with the configuration pragma file. + + if Current_Source_Unit /= No_Unit then + declare + U : constant Unit_Number_Type := + Get_Source_Unit + (Primary_Location (Diagnostic).Span.Ptr); + begin + if Try_Semantics then + if Fatal_Error (U) = None then + Set_Fatal_Error (U, Error_Ignored); + end if; + else + Set_Fatal_Error (U, Error_Detected); + end if; + end; + end if; + + -- Disable warnings on unused use clauses and the like. Otherwise, an + -- error might hide a reference to an entity in a used package, so + -- after fixing the error, the use clause no longer looks like it was + -- unused. + + Warnsw.Check_Unreferenced := False; + Warnsw.Check_Unreferenced_Formals := False; + end Handle_Serious_Error; + begin + Insert_Based_On_Location (All_Diagnostics, Diagnostic); + + if Update_Count then + Update_Diagnostic_Count (Diagnostic); + end if; + + if Diagnostic.Kind = Error and then Diagnostic.Serious then + Handle_Serious_Error; + end if; + end Record_Diagnostic; + + ---------------------- + -- Print_Diagnostic -- + ---------------------- + + procedure Print_Diagnostic (Diagnostic : Diagnostic_Type) is + + begin + if Debug_Flag_FF then + Diagnostics.Pretty_Emitter.Print_Diagnostic (Diagnostic); + else + Diagnostics.Brief_Emitter.Print_Diagnostic (Diagnostic); + end if; + end Print_Diagnostic; + + ---------------------- + -- Primary_Location -- + ---------------------- + + function Primary_Location + (Diagnostic : Diagnostic_Type) return Labeled_Span_Type + is + begin + return Get_Primary_Labeled_Span (Diagnostic.Locations); + end Primary_Location; + + --------------------- + -- Make_Diagnostic -- + --------------------- + + function Make_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes) + return Diagnostic_Type + is + D : Diagnostic_Type; + begin + D.Message := new String'(Msg); + D.Id := Id; + D.Kind := Kind; + + if Id /= No_Diagnostic_Id then + pragma Assert (Switch = Diagnostic_Entries (Id).Switch, + "Provided switch must be the same as in the registry"); + end if; + D.Switch := Switch; + + pragma Assert (Location.Is_Primary, "Main location must be primary"); + Add_Location (D, Location); + + for I in Spans'Range loop + Add_Location (D, Spans (I)); + end loop; + + for I in Sub_Diags'Range loop + Add_Sub_Diagnostic (D, Sub_Diags (I)); + end loop; + + for I in Fixes'Range loop + Add_Fix (D, Fixes (I)); + end loop; + + return D; + end Make_Diagnostic; + + ----------------------- + -- Record_Diagnostic -- + ----------------------- + + procedure Record_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes) + is + + begin + Record_Diagnostic + (Make_Diagnostic + (Msg => Msg, + Location => Location, + Id => Id, + Kind => Kind, + Switch => Switch, + Spans => Spans, + Sub_Diags => Sub_Diags, + Fixes => Fixes)); + end Record_Diagnostic; + + ------------------ + -- Labeled_Span -- + ------------------ + + function Labeled_Span (Span : Source_Span; + Label : String := ""; + Is_Primary : Boolean := True; + Is_Region : Boolean := False) + return Labeled_Span_Type + is + L : Labeled_Span_Type; + begin + L.Span := Span; + if Label /= "" then + L.Label := new String'(Label); + end if; + L.Is_Primary := Is_Primary; + L.Is_Region := Is_Region; + + return L; + end Labeled_Span; + + -------------------------- + -- Primary_Labeled_Span -- + -------------------------- + + function Primary_Labeled_Span (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type + is begin + return Labeled_Span (Span => Span, Label => Label, Is_Primary => True); + end Primary_Labeled_Span; + + -------------------------- + -- Primary_Labeled_Span -- + -------------------------- + + function Primary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type + is + begin + return Primary_Labeled_Span (To_Full_Span (N), Label); + end Primary_Labeled_Span; + + ---------------------------- + -- Secondary_Labeled_Span -- + ---------------------------- + + function Secondary_Labeled_Span + (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type + is + begin + return Labeled_Span (Span => Span, Label => Label, Is_Primary => False); + end Secondary_Labeled_Span; + + ---------------------------- + -- Secondary_Labeled_Span -- + ---------------------------- + + function Secondary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type + is + begin + return Secondary_Labeled_Span (To_Full_Span (N), Label); + end Secondary_Labeled_Span; + + -------------- + -- Sub_Diag -- + -------------- + + function Sub_Diag (Msg : String; + Kind : Sub_Diagnostic_Kind := + Diagnostics.Continuation; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + S : Sub_Diagnostic_Type; + begin + S.Message := new String'(Msg); + S.Kind := Kind; + + for I in Locations'Range loop + Add_Location (S, Locations (I)); + end loop; + + return S; + end Sub_Diag; + + ------------------ + -- Continuation -- + ------------------ + + function Continuation (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + begin + return Sub_Diag (Msg, Diagnostics.Continuation, Locations); + end Continuation; + + ---------- + -- Help -- + ---------- + + function Help (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + begin + return Sub_Diag (Msg, Diagnostics.Help, Locations); + end Help; + + ---------------- + -- Suggestion -- + ---------------- + + function Suggestion (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type + is + begin + return Sub_Diag (Msg, Diagnostics.Suggestion, Locations); + end Suggestion; + + --------- + -- Fix -- + --------- + + function Fix + (Description : String; + Edits : Edit_Array; + Applicability : Applicability_Type := Unspecified) return Fix_Type + is + F : Fix_Type; + begin + F.Description := new String'(Description); + + for I in Edits'Range loop + Add_Edit (F, Edits (I)); + end loop; + + F.Applicability := Applicability; + + return F; + end Fix; + + ---------- + -- Edit -- + ---------- + + function Edit (Text : String; Span : Source_Span) return Edit_Type is + + begin + return (Text => new String'(Text), Span => Span); + end Edit; + +end Diagnostics; diff --git a/gcc/ada/diagnostics.ads b/gcc/ada/diagnostics.ads new file mode 100644 index 0000000..18afb1c --- /dev/null +++ b/gcc/ada/diagnostics.ads @@ -0,0 +1,481 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- D I A G N O S T I C S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; +with GNAT.Lists; use GNAT.Lists; + +package Diagnostics is + + type Diagnostic_Id is + (No_Diagnostic_Id, + GNAT0001, + GNAT0002, + GNAT0003, + GNAT0004, + GNAT0005, + GNAT0006, + GNAT0007, + GNAT0008, + GNAT0009, + GNAT0010); + + -- Labeled_Span_Type represents a span of source code that is associated + -- with a textual label. Primary spans indicate the primary location of the + -- diagnostic. Non-primary spans are used to indicate secondary locations. + -- + -- Spans can contain labels that are used to annotate the highlighted span. + -- Usually, the label is a short and concise message that provide + -- additional allthough non-critical information about the span. This is + -- an important since labels are not printed in the brief output and are + -- only present in the pretty and structural outputs. That is an important + -- distintion when choosing between a label and a sub-diagnostic. + type Labeled_Span_Type is record + Label : String_Ptr := null; + -- Text associated with the span + + Span : Source_Span := (others => No_Location); + -- Textual region in the source code + + Is_Primary : Boolean := True; + -- Primary spans are used to indicate the primary location of the + -- diagnostic. Typically there should just be one primary span per + -- diagnostic. + -- Non-primary spans are used to indicate secondary locations and + -- typically are formatted in a different way or omitted in some + -- contexts. + + Is_Region : Boolean := False; + -- Regional spans are multiline spans that have a unique way of being + -- displayed in the pretty output. + end record; + + No_Labeled_Span : constant Labeled_Span_Type := (others => <>); + + procedure Destroy (Elem : in out Labeled_Span_Type); + pragma Inline (Destroy); + + package Labeled_Span_Lists is new Doubly_Linked_Lists + (Element_Type => Labeled_Span_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + subtype Labeled_Span_List is Labeled_Span_Lists.Doubly_Linked_List; + + type Sub_Diagnostic_Kind is + (Continuation, + Help, + Note, + Suggestion); + + -- Sub_Diagnostic_Type represents a sub-diagnostic message that is meant + -- to provide additional information about the primary diagnostic message. + -- + -- Sub-diagnostics are usually constructed with a full sentence as the + -- message and provide important context to the main diagnostic message or + -- some concrete action to the user. + -- + -- This is different from the labels of labeled spans which are meant to be + -- short and concise and are mostly there to annotate the higlighted span. + + type Sub_Diagnostic_Type is record + Kind : Sub_Diagnostic_Kind; + + Message : String_Ptr; + + Locations : Labeled_Span_List; + end record; + + procedure Add_Location + (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type); + + function Primary_Location + (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type; + + procedure Destroy (Elem : in out Sub_Diagnostic_Type); + pragma Inline (Destroy); + + package Sub_Diagnostic_Lists is new Doubly_Linked_Lists + (Element_Type => Sub_Diagnostic_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Sub_Diagnostic_List is Sub_Diagnostic_Lists.Doubly_Linked_List; + + -- An Edit_Type represents a textual edit that is associated with a Fix. + type Edit_Type is record + Span : Source_Span; + -- Region of the file to be removed + + Text : String_Ptr; + -- Text to be inserted at the start location of the span + end record; + + procedure Destroy (Elem : in out Edit_Type); + pragma Inline (Destroy); + + package Edit_Lists is new Doubly_Linked_Lists + (Element_Type => Edit_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Edit_List is Edit_Lists.Doubly_Linked_List; + + -- Type Applicability_Type will indicate the state of the resulting code + -- after applying a fix. + -- * Option Has_Placeholders indicates that the fix contains placeholders + -- that the user would need to fill. + -- * Option Legal indicates that applying the fix will result in legal Ada + -- code. + -- * Option Possibly_Illegal indicates that applying the fix will result in + -- possibly legal, but also possibly illegal Ada code. + type Applicability_Type is + (Has_Placeholders, + Legal, + Possibly_Illegal, + Unspecified); + + type Fix_Type is record + Description : String_Ptr := null; + -- Message describing the fix that will be displayed to the user. + + Applicability : Applicability_Type := Unspecified; + + Edits : Edit_List; + -- File changes for the fix. + end record; + + procedure Destroy (Elem : in out Fix_Type); + pragma Inline (Destroy); + + package Fix_Lists is new Doubly_Linked_Lists + (Element_Type => Fix_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Fix_List is Fix_Lists.Doubly_Linked_List; + + procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type); + + type Status_Type is + (Active, + Deprecated); + + type Switch_Id is ( + No_Switch_Id, + gnatwb, + gnatwc, + gnatwd, + gnatwf, + gnatwg, + gnatwh, + gnatwi, + gnatwj, + gnatwk, + gnatwl, + gnatwm, + gnatwo, + gnatwp, + gnatwq, + gnatwr, + gnatwt, + gnatwu, + gnatwv, + gnatww, + gnatwx, + gnatwy, + gnatwz, + gnatw_dot_a, + gnatw_dot_b, + gnatw_dot_c, + gnatw_dot_f, + gnatw_dot_h, + gnatw_dot_i, + gnatw_dot_j, + gnatw_dot_k, + gnatw_dot_l, + gnatw_dot_m, + gnatw_dot_n, + gnatw_dot_o, + gnatw_dot_p, + gnatw_dot_q, + gnatw_dot_r, + gnatw_dot_s, + gnatw_dot_t, + gnatw_dot_u, + gnatw_dot_v, + gnatw_dot_w, + gnatw_dot_x, + gnatw_dot_y, + gnatw_dot_z, + gnatw_underscore_a, + gnatw_underscore_c, + gnatw_underscore_j, + gnatw_underscore_l, + gnatw_underscore_p, + gnatw_underscore_q, + gnatw_underscore_r, + gnatw_underscore_s, + gnaty, + gnatya, + gnatyb, + gnatyc, + gnatyd, + gnatye, + gnatyf, + gnatyh, + gnatyi, + gnatyk, + gnatyl, + gnatym, + gnatyn, + gnatyo, + gnatyp, + gnatyr, + gnatys, + gnatyu, + gnatyx, + gnatyz, + gnatyaa, + gnatybb, + gnatycc, + gnatydd, + gnatyii, + gnatyll, + gnatymm, + gnatyoo, + gnatyss, + gnatytt, + gnatel + ); + + subtype Active_Switch_Id is Switch_Id range gnatwb .. gnatel; + -- The range of switch ids that represent switches that trigger a specific + -- diagnostic check. + + type Switch_Type is record + + Status : Status_Type := Active; + -- The status will indicate whether the switch is currently active, + -- or has been deprecated. A deprecated switch will not control + -- diagnostics, and will not be emitted by the GNAT usage. + + Human_Id : String_Ptr := null; + -- The Human_Id will be a unique and stable string-based ID which + -- identifies the content of the switch within the switch registry. + -- This ID will appear in SARIF readers. + + Short_Name : String_Ptr := null; + -- The Short_Name will denote the -gnatXX name of the switch. + + Description : String_Ptr := null; + -- The description will contain the description of the switch, as it is + -- currently emitted by the GNAT usage. + + Documentation_Url : String_Ptr := null; + -- The documentation_url will point to the AdaCore documentation site + -- for the switch. + + end record; + + type Diagnostic_Kind is + (Error, + Warning, + Default_Warning, + -- Warning representing the old warnings created with the '??' insertion + -- character. These warning have the [enabled by default] tag. + Restriction_Warning, + -- Warning representing the old warnings created with the '?*?' + -- insertion character. These warning have the [restriction warning] + -- tag. + Style, + Tagless_Warning, + -- Warning representing the old warnings created with the '?' insertion + -- character. + Info, + Info_Warning + -- Info warnings are old messages where both warning and info were set + -- to true. These info messages behave like warnings and are usually + -- accompanied by a warning tag. + ); + + type Diagnostic_Entry_Type is record + Status : Status_Type := Active; + + Human_Id : String_Ptr := null; + -- A human readable code for the diagnostic. If the diagnostic has a + -- switch with a human id then the human_id of the switch shall be used + -- in SARIF reports. + + Documentation : String_Ptr := null; + + Switch : Switch_Id := No_Switch_Id; + -- The switch that controls the diagnostic message. + end record; + + type Diagnostic_Type is record + + Id : Diagnostic_Id := No_Diagnostic_Id; + + Kind : Diagnostic_Kind := Error; + + Switch : Switch_Id := No_Switch_Id; + + Message : String_Ptr := null; + + Warn_Err : Boolean := False; + -- Signal whether the diagnostic was converted from a warning to an + -- error. This needs to be set during the message emission as this + -- behavior depends on the context of the code. + + Serious : Boolean := True; + -- Typically all errors are considered serious and the compiler should + -- stop its processing since the tree is essentially invalid. However, + -- some errors are not serious and the compiler can continue its + -- processing to discover more critical errors. + + Locations : Labeled_Span_List := Labeled_Span_Lists.Nil; + + Sub_Diagnostics : Sub_Diagnostic_List := Sub_Diagnostic_Lists.Nil; + + Fixes : Fix_List := Fix_Lists.Nil; + end record; + + procedure Destroy (Elem : in out Diagnostic_Type); + pragma Inline (Destroy); + + package Diagnostics_Lists is new Doubly_Linked_Lists + (Element_Type => Diagnostic_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Diagnostic_List is Diagnostics_Lists.Doubly_Linked_List; + + All_Diagnostics : Diagnostic_List := Diagnostics_Lists.Create; + + procedure Add_Location + (Diagnostic : in out Diagnostic_Type; Location : Labeled_Span_Type); + + procedure Add_Sub_Diagnostic + (Diagnostic : in out Diagnostic_Type; + Sub_Diagnostic : Sub_Diagnostic_Type); + + procedure Add_Fix (Diagnostic : in out Diagnostic_Type; Fix : Fix_Type); + + procedure Record_Diagnostic (Diagnostic : Diagnostic_Type; + Update_Count : Boolean := True); + + procedure Print_Diagnostic (Diagnostic : Diagnostic_Type); + + function Primary_Location + (Diagnostic : Diagnostic_Type) return Labeled_Span_Type; + + type Labeled_Span_Array is + array (Positive range <>) of Labeled_Span_Type; + type Sub_Diagnostic_Array is + array (Positive range <>) of Sub_Diagnostic_Type; + type Fix_Array is + array (Positive range <>) of Fix_Type; + type Edit_Array is + array (Positive range <>) of Edit_Type; + + No_Locations : constant Labeled_Span_Array (1 .. 0) := (others => <>); + No_Sub_Diags : constant Sub_Diagnostic_Array (1 .. 0) := (others => <>); + No_Fixes : constant Fix_Array (1 .. 0) := (others => <>); + No_Edits : constant Edit_Array (1 .. 0) := (others => <>); + + function Make_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes) + return Diagnostic_Type; + + procedure Record_Diagnostic + (Msg : String; + Location : Labeled_Span_Type; + Id : Diagnostic_Id := No_Diagnostic_Id; + Kind : Diagnostic_Kind := Diagnostics.Error; + Switch : Switch_Id := No_Switch_Id; + Spans : Labeled_Span_Array := No_Locations; + Sub_Diags : Sub_Diagnostic_Array := No_Sub_Diags; + Fixes : Fix_Array := No_Fixes); + + function Labeled_Span (Span : Source_Span; + Label : String := ""; + Is_Primary : Boolean := True; + Is_Region : Boolean := False) + return Labeled_Span_Type; + + function Primary_Labeled_Span (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type; + + function Primary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type; + + function Secondary_Labeled_Span (Span : Source_Span; + Label : String := "") + return Labeled_Span_Type; + + function Secondary_Labeled_Span (N : Node_Or_Entity_Id; + Label : String := "") + return Labeled_Span_Type; + + function Sub_Diag (Msg : String; + Kind : Sub_Diagnostic_Kind := + Diagnostics.Continuation; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Continuation (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Help (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Suggestion (Msg : String; + Locations : Labeled_Span_Array := No_Locations) + return Sub_Diagnostic_Type; + + function Fix (Description : String; + Edits : Edit_Array; + Applicability : Applicability_Type := Unspecified) + return Fix_Type; + + function Edit (Text : String; + Span : Source_Span) + return Edit_Type; +end Diagnostics; diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst index 27be5e0..e7cd73f 100644 --- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst +++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst @@ -35,7 +35,8 @@ file, or in a ``.adc`` file corresponding to your project. * The ``-gnatX`` option, that you can pass to the compiler directly, will activate the curated subset of extensions. -.. attention:: You can activate the extended set of extensions by using either +.. attention:: You can activate the experimental set of extensions + in addition by using either the ``-gnatX0`` command line flag, or the pragma ``Extensions_Allowed`` with ``All_Extensions`` as an argument. However, it is not recommended you use this subset for serious projects; it is only meant as a technology preview @@ -46,6 +47,9 @@ file, or in a ``.adc`` file corresponding to your project. Curated Extensions ================== +Features activated via ``-gnatX`` or +``pragma Extensions_Allowed (On)``. + Local Declarations Without Block -------------------------------- @@ -356,6 +360,9 @@ https://github.com/AdaCore/ada-spark-rfcs/blob/master/considered/rfc-oop-first-c Experimental Language Extensions ================================ +Features activated via ``-gnatX0`` or +``pragma Extensions_Allowed (All_Extensions)``. + Conditional when constructs --------------------------- @@ -662,3 +669,74 @@ Example: Link to the original RFC: https://github.com/AdaCore/ada-spark-rfcs/blob/topic/finalization-rehaul/considered/rfc-generalized-finalization.md + +Inference of Dependent Types in Generic Instantiations +------------------------------------------------------ + +If a generic formal type T2 depends on another formal type T1, +the actual for T1 can be inferred from the actual for T2. +That is, you can give the actual for T2, and leave out the one +for T1. + +For example, ``Ada.Unchecked_Deallocation`` has two generic formals: + +.. code-block:: ada + + generic + type Object (<>) is limited private; + type Name is access Object; + procedure Ada.Unchecked_Deallocation (X : in out Name); + +where ``Name`` depends on ``Object``. With this language extension, +you can leave out the actual for ``Object``, as in: + +.. code-block:: ada + + type Integer_Access is access all Integer; + + procedure Free is new Unchecked_Deallocation (Name => Integer_Access); + +The compiler will infer that the actual type for ``Object`` is ``Integer``. +Note that named notation is always required when using inference. + +The following inferences are allowed: + +- For a formal access type, the designated type can be inferred. + +- For a formal array type, the index type(s) and the component + type can be inferred. + +- For a formal type with discriminats, the type(s) of the discriminants + can be inferred. + +Example for arrays: + +.. code-block:: ada + + generic + type Element_Type is private; + type Index_Type is (<>); + type Array_Type is array (Index_Type range <>) of Element_Type; + package Array_Operations is + ... + end Array_Operations; + + ... + + type Int_Array is array (Positive range <>) of Integer; + + package Int_Array_Operations is new Array_Operations (Array_Type => Int_Array); + +The index and component types of ``Array_Type`` are inferred from +``Int_Array``, so that the above instantiation is equivalent to +the following standard-Ada instantiation: + +.. code-block:: ada + + package Int_Array_Operations is new Array_Operations + (Element_Type => Integer, + Index_Type => Positive, + Array_Type => Int_Array); + +Link to the original RFC: +https://github.com/AdaCore/ada-spark-rfcs/blob/topic/generic_instantiations/considered/rfc-inference-of-dependent-types.md diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index 07ca2ea..d8501b2 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -3433,7 +3433,7 @@ of the pragma in the :title:`GNAT_Reference_manual`). .. index:: -gnatw_l (gcc) :switch:`-gnatw_l` - *Activate warnings on inheritely limited types.* + *Activate warnings on implicitly limited types.* This switch causes the compiler trigger warnings on record types that do not have a limited keyword but contain a component that is a limited type. @@ -3442,9 +3442,9 @@ of the pragma in the :title:`GNAT_Reference_manual`). .. index:: -gnatw_L (gcc) :switch:`-gnatw_L` - *Suppress warnings on inheritely limited types.* + *Suppress warnings on implicitly limited types.* - This switch suppresses warnings on inheritely limited types. + This switch suppresses warnings on implicitly limited types. .. index:: -gnatwm (gcc) @@ -4783,7 +4783,7 @@ checks to be performed. The following checks are defined: then proper indentation is checked, with the digit indicating the indentation level required. A value of zero turns off this style check. The rule checks that the following constructs start on a column that is - a multiple of the alignment level: + one plus a multiple of the alignment level: * beginnings of declarations (except record component declarations) and statements; @@ -4794,10 +4794,10 @@ checks to be performed. The following checks are defined: or body or that completes a compound statement. Full line comments must be - aligned with the ``--`` starting on a column that is a multiple of + aligned with the ``--`` starting on a column that is one plus a multiple of the alignment level, or they may be aligned the same way as the following non-blank line (this is useful when full line comments appear in the middle - of a statement, or they may be aligned with the source line on the previous + of a statement), or they may be aligned with the source line on the previous non-blank line. .. index:: -gnatya (gcc) diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index c8d87f0..f4660c4 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -33,6 +33,7 @@ with Atree; use Atree; with Casing; use Casing; with Csets; use Csets; with Debug; use Debug; +with Diagnostics.Converter; use Diagnostics.Converter; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -163,13 +164,6 @@ package body Errout is -- N_Defining_Program_Unit_Name, and N_Expanded_Name, the Prefix is -- included as well. - procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); - -- Add a sequence of characters to the current message. The characters may - -- be one of the special insertion characters (see documentation in spec). - -- Flag is the location at which the error is to be posted, which is used - -- to determine whether or not the # insertion needs a file name. The - -- variables Msg_Buffer are set on return Msglen. - procedure Set_Posted (N : Node_Id); -- Sets the Error_Posted flag on the given node, and all its parents that -- are subexpressions and then on the parent non-subexpression construct @@ -2563,6 +2557,10 @@ package body Errout is -- Local subprograms + procedure Emit_Error_Msgs; + -- Emit all error messages in the table use the pretty printed format if + -- -gnatdF is used otherwise use the brief format. + procedure Write_Error_Summary; -- Write error summary @@ -2602,6 +2600,108 @@ package body Errout is -- SGR_Span is the SGR string to start the section of code in the span, -- that should be closed with SGR_Reset. + -------------------- + -- Emit_Error_Msgs -- + --------------------- + + procedure Emit_Error_Msgs is + Use_Prefix : Boolean; + E : Error_Msg_Id; + begin + Set_Standard_Error; + + E := First_Error_Msg; + while E /= No_Error_Msg loop + + -- If -gnatdF is used, separate main messages from previous + -- messages with a newline (unless it is an info message) and + -- make continuation messages follow the main message with only + -- an indentation of two space characters, without repeating + -- file:line:col: prefix. + + Use_Prefix := + not (Debug_Flag_FF and then Errors.Table (E).Msg_Cont); + + if not Errors.Table (E).Deleted then + + if Debug_Flag_FF then + if Errors.Table (E).Msg_Cont then + Write_Str (" "); + elsif not Errors.Table (E).Info then + Write_Eol; + end if; + end if; + + if Use_Prefix then + Write_Str (SGR_Locus); + + if Full_Path_Name_For_Brief_Errors then + Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); + else + Write_Name (Reference_Name (Errors.Table (E).Sfile)); + end if; + + Write_Char (':'); + Write_Int (Int (Physical_To_Logical + (Errors.Table (E).Line, + Errors.Table (E).Sfile))); + Write_Char (':'); + + if Errors.Table (E).Col < 10 then + Write_Char ('0'); + end if; + + Write_Int (Int (Errors.Table (E).Col)); + Write_Str (": "); + + Write_Str (SGR_Reset); + end if; + + Output_Msg_Text (E); + Write_Eol; + + -- If -gnatdF is used, write the source code line + -- corresponding to the location of the main message (unless + -- it is an info message). Also write the source code line + -- corresponding to an insertion location inside + -- continuation messages. + + if Debug_Flag_FF + and then not Errors.Table (E).Info + then + if Errors.Table (E).Msg_Cont then + declare + Loc : constant Source_Ptr := + Errors.Table (E).Insertion_Sloc; + begin + if Loc /= No_Location then + Write_Source_Code_Lines + (To_Span (Loc), SGR_Span => SGR_Note); + end if; + end; + + else + declare + SGR_Span : constant String := + (if Errors.Table (E).Info then SGR_Note + elsif Errors.Table (E).Warn + and then not Errors.Table (E).Warn_Err + then SGR_Warning + else SGR_Error); + begin + Write_Source_Code_Lines + (Errors.Table (E).Optr, SGR_Span); + end; + end if; + end if; + end if; + + E := Errors.Table (E).Next; + end loop; + + Set_Standard_Output; + end Emit_Error_Msgs; + ------------------------- -- Write_Error_Summary -- ------------------------- @@ -3094,7 +3194,6 @@ package body Errout is E : Error_Msg_Id; Err_Flag : Boolean; - Use_Prefix : Boolean; -- Start of processing for Output_Messages @@ -3155,100 +3254,25 @@ package body Errout is Set_Standard_Output; - -- Brief Error mode - - elsif Brief_Output or (not Full_List and not Verbose_Mode) then - Set_Standard_Error; - - E := First_Error_Msg; - while E /= No_Error_Msg loop - - -- If -gnatdF is used, separate main messages from previous - -- messages with a newline (unless it is an info message) and - -- make continuation messages follow the main message with only - -- an indentation of two space characters, without repeating - -- file:line:col: prefix. - - Use_Prefix := - not (Debug_Flag_FF and then Errors.Table (E).Msg_Cont); - - if not Errors.Table (E).Deleted and then not Debug_Flag_KK then - - if Debug_Flag_FF then - if Errors.Table (E).Msg_Cont then - Write_Str (" "); - elsif not Errors.Table (E).Info then - Write_Eol; - end if; - end if; - - if Use_Prefix then - Write_Str (SGR_Locus); - - if Full_Path_Name_For_Brief_Errors then - Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); - else - Write_Name (Reference_Name (Errors.Table (E).Sfile)); - end if; - - Write_Char (':'); - Write_Int (Int (Physical_To_Logical - (Errors.Table (E).Line, - Errors.Table (E).Sfile))); - Write_Char (':'); - - if Errors.Table (E).Col < 10 then - Write_Char ('0'); - end if; - - Write_Int (Int (Errors.Table (E).Col)); - Write_Str (": "); + -- Do not print any messages if all messages are killed -gnatdK - Write_Str (SGR_Reset); - end if; + elsif Debug_Flag_KK then - Output_Msg_Text (E); - Write_Eol; + null; - -- If -gnatdF is used, write the source code line corresponding - -- to the location of the main message (unless it is an info - -- message). Also write the source code line corresponding to - -- an insertion location inside continuation messages. + -- Brief Error mode - if Debug_Flag_FF - and then not Errors.Table (E).Info - then - if Errors.Table (E).Msg_Cont then - declare - Loc : constant Source_Ptr := - Errors.Table (E).Insertion_Sloc; - begin - if Loc /= No_Location then - Write_Source_Code_Lines - (To_Span (Loc), SGR_Span => SGR_Note); - end if; - end; + elsif Brief_Output or (not Full_List and not Verbose_Mode) then - else - declare - SGR_Span : constant String := - (if Errors.Table (E).Info then SGR_Note - elsif Errors.Table (E).Warn - and then not Errors.Table (E).Warn_Err - then SGR_Warning - else SGR_Error); - begin - Write_Source_Code_Lines - (Errors.Table (E).Optr, SGR_Span); - end; - end if; - end if; - end if; + -- Use updated diagnostic mechanism - E := Errors.Table (E).Next; - end loop; + if Debug_Flag_Underscore_DD then + Convert_Errors_To_Diagnostics; - Set_Standard_Output; + Emit_Diagnostics; + else + Emit_Error_Msgs; + end if; end if; -- Full source listing case diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 2b0410a..fce7d9b502 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -292,31 +292,31 @@ package Errout is -- not necessary to go through any computational effort to include it. -- -- Note: this usage is obsolete; use ?? ?*? ?$? ?x? ?.x? ?_x? to - -- specify the string to be added when Warn_Doc_Switch is set to True. - -- If this switch is True, then for simple ? messages it has no effect. - -- This simple form is to ease transition and may be removed later - -- except for GNATprove-specific messages (info and warnings) which are - -- not subject to the same GNAT warning switches. + -- specify the string to be added when Warning_Doc_Switch is set to + -- True. If this switch is True, then for simple ? messages it has no + -- effect. This simple form is to ease transition and may be removed + -- later except for GNATprove-specific messages (info and warnings) + -- which are not subject to the same GNAT warning switches. -- Insertion character ?? (Two question marks: default warning) - -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ?, but if the flag Warning_Doc_Switch is True, adds the string -- "[enabled by default]" at the end of the warning message. For -- continuations, use this in each continuation message. -- Insertion character ?x? ?.x? ?_x? (warning with switch) -- "x" is a (lower-case) warning switch character. - -- Like ??, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ??, but if the flag Warning_Doc_Switch is True, adds the string -- "[-gnatwx]", "[-gnatw.x]", "[-gnatw_x]", or "[-gnatyx]" (for style -- messages), at the end of the warning message. For continuations, use -- this on each continuation message. -- Insertion character ?*? (restriction warning) - -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ?, but if the flag Warning_Doc_Switch is True, adds the string -- "[restriction warning]" at the end of the warning message. For -- continuations, use this on each continuation message. -- Insertion character ?$? (elaboration informational messages) - -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string + -- Like ?, but if the flag Warning_Doc_Switch is True, adds the string -- "[-gnatel]" at the end of the info message. This is used for the -- messages generated by the switch -gnatel. For continuations, use -- this on each continuation message. @@ -884,6 +884,13 @@ package Errout is -- ignored. A call with To=False restores the default treatment in which -- error calls are treated as usual (and as described in this spec). + procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); + -- Add a sequence of characters to the current message. The characters may + -- be one of the special insertion characters (see documentation in spec). + -- Flag is the location at which the error is to be posted, which is used + -- to determine whether or not the # insertion needs a file name. The + -- variables Msg_Buffer are set on return Msglen. + procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) renames Erroutc.Set_Warnings_Mode_Off; -- Called in response to a pragma Warnings (Off) to record the source diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 84c7a4b..702c4bb 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -4797,7 +4797,7 @@ package body Exp_Attr is -- then replace this attribute with a reference to 'Range_Length -- of the appropriate index subtype (since otherwise the -- back end will try to give us the value of 'Length for - -- this implementation type).s + -- this implementation type). elsif Is_Constrained (Ptyp) then Rewrite (N, @@ -4868,6 +4868,73 @@ package body Exp_Attr is end if; end; + -- Overflow-related transformations need Length attribute rewritten + -- using non-attribute expressions. So generate + -- (if Pref'First > Pref'Last + -- then 0 + -- else ((Pref'Last - Pref'First) + 1)) . + + elsif Overflow_Check_Mode in Minimized_Or_Eliminated + + -- This Comes_From_Source test fixes a regression test failure + -- involving a Length attribute reference generated as part of + -- the expansion of a concatentation operator; it is unclear + -- whether this is the right solution to that problem. + + and then Comes_From_Source (N) + + -- This Base_Type equality test is so that we only perform this + -- transformation if we can do it without introducing + -- a type conversion anywhere in the resulting expansion; + -- a type conversion is just as bad as a Length attribute + -- reference for those overflow-related transformations. + + and then Btyp = Base_Type (Get_Index_Subtype (N)) + + then + declare + function Prefix_Bound + (Bound_Attr_Name : Name_Id; Is_First_Copy : Boolean := False) + return Node_Id; + -- constructs a Pref'First or Pref'Last attribute reference + + ------------------ + -- Prefix_Bound -- + ------------------ + + function Prefix_Bound + (Bound_Attr_Name : Name_Id; Is_First_Copy : Boolean := False) + return Node_Id + is + Prefix : constant Node_Id := + (if Is_First_Copy + then Duplicate_Subexpr (Pref) + else Duplicate_Subexpr_No_Checks (Pref)); + begin + return Make_Attribute_Reference (Loc, + Prefix => Prefix, + Attribute_Name => Bound_Attr_Name, + Expressions => New_Copy_List (Exprs)); + end Prefix_Bound; + begin + Rewrite (N, + Make_If_Expression (Loc, + Expressions => + New_List ( + Node1 => Make_Op_Gt (Loc, + Prefix_Bound (Name_First, + Is_First_Copy => True), + Prefix_Bound (Name_Last)), + Node2 => Make_Integer_Literal (Loc, 0), + Node3 => Make_Op_Add (Loc, + Make_Op_Subtract (Loc, + Prefix_Bound (Name_Last), + Prefix_Bound (Name_First)), + Make_Integer_Literal (Loc, 1))))); + + Analyze_And_Resolve (N, Typ); + end; + -- Otherwise leave it to the back end else diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 4f6fa4c..ff808aa 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7658,11 +7658,9 @@ package body Exp_Ch3 is and then Is_Library_Level_Entity (Def_Id) then declare - Prag : Node_Id; + Prag : constant Node_Id := + Make_Linker_Section_Pragma (Def_Id, Loc, ".persistent.bss"); begin - Prag := - Make_Linker_Section_Pragma - (Def_Id, Sloc (N), ".persistent.bss"); Insert_After (N, Prag); Analyze (Prag); end; @@ -8349,10 +8347,8 @@ package body Exp_Ch3 is -- An Ada 2012 stand-alone object of an anonymous access type declare - Loc : constant Source_Ptr := Sloc (N); - Level : constant Entity_Id := - Make_Defining_Identifier (Sloc (N), + Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Def_Id), Suffix => "L")); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 3c87c0e..c868234 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -517,15 +517,11 @@ package body Exp_Ch6 is else Desig_Typ := Directly_Designated_Type (Ptr_Typ); - -- Check for a library-level access type whose designated type has - -- suppressed finalization or the access type is subject to pragma - -- No_Heap_Finalization. Such an access type lacks a collection. Pass - -- a null actual to callee in order to signal a missing collection. - - if Is_Library_Level_Entity (Ptr_Typ) - and then (Finalize_Storage_Only (Desig_Typ) - or else No_Heap_Finalization (Ptr_Typ)) - then + -- Check for a type that is subject to pragma No_Heap_Finalization. + -- Such a type lacks a collection. Pass a null actual to callee to + -- signal a missing collection. + + if No_Heap_Finalization (Ptr_Typ) then Actual := Make_Null (Loc); -- Types in need of finalization actions diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 958657f..9b82a9f 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -489,7 +489,8 @@ package body Exp_Ch9 is -- <actualN> := P.<formalN>; procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id); - -- Reset the scope of declarations and blocks at the top level of Bod to + -- Reset the scope of declarations and blocks at the top level of Bod and + -- of nested object declarations with scope pointing to the entry entity to -- be E. Bod is either a block or a subprogram body. Used after expanding -- various kinds of entry bodies into their corresponding constructs. This -- is needed during unnesting to determine whether a body generated for an @@ -14868,12 +14869,34 @@ package body Exp_Ch9 is Set_Scope (Entity (Identifier (N)), E); return Skip; + -- Reset scope for object declaration which scope is the task entry. + -- + -- Also look inside the declaration (in particular in the expression + -- if present) because we may have expanded to something like: + + -- O1 : Typ := do + -- TMP1 : OTyp := ...; + -- ... + -- in TMP1; + + -- And the scope for TMP1 is Scope (O1). We need to look inside the + -- declaration to also reset such scope. + + elsif Nkind (N) = N_Object_Declaration then + if Present (Scope (Defining_Entity (N))) + and then Ekind (Scope (Defining_Entity (N))) + in E_Entry | E_Entry_Family + then + Set_Scope (Defining_Entity (N), E); + end if; + -- Ditto for a package declaration or a full type declaration, etc. elsif (Nkind (N) = N_Package_Declaration and then N /= Specification (N)) or else Nkind (N) in N_Declaration or else Nkind (N) in N_Renaming_Declaration + or else Nkind (N) in N_Implicit_Label_Declaration then Set_Scope (Defining_Entity (N), E); return Skip; diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index e5d84cc..ce052c1 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -896,9 +896,7 @@ package body Exp_Imgv is -- Apply a validity check, since it is a bit drastic to get a -- completely junk image value for an invalid value. - if not Expr_Known_Valid (Expr) then - Insert_Valid_Check (Expr); - end if; + Insert_Valid_Check (Expr); -- Generate: -- P1 : constant Natural := Typ'Pos (Typ?(Expr)); @@ -1249,9 +1247,7 @@ package body Exp_Imgv is -- Apply a validity check, since it is a bit drastic to get a -- completely junk image value for an invalid value. - if not Expr_Known_Valid (Expr) then - Insert_Valid_Check (Expr); - end if; + Insert_Valid_Check (Expr); Enum_Case := True; end if; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index a076eb0..0db0a66 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -109,12 +109,6 @@ package body Exp_Intr is -- Expand a call to corresponding function, declared in an instance of -- System.Address_To_Access_Conversions. - procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); - -- Rewrite the node as the appropriate string literal or positive - -- constant. Nam is the name of one of the intrinsics declared in - -- GNAT.Source_Info; see g-souinf.ads for documentation of these - -- intrinsics. - --------------------- -- Add_Source_Info -- --------------------- diff --git a/gcc/ada/exp_intr.ads b/gcc/ada/exp_intr.ads index 699d1c8..75f24bf 100644 --- a/gcc/ada/exp_intr.ads +++ b/gcc/ada/exp_intr.ads @@ -39,6 +39,11 @@ package Exp_Intr is -- documentation of these intrinsics. Loc is passed to provide location -- information where it is needed. + procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); + -- Rewrite the node as the appropriate string literal or positive constant. + -- Nam is the name of one of the intrinsics declared in GNAT.Source_Info; + -- see g-souinf.ads for documentation of these intrinsics. + procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id); -- N is either a function call node, a procedure call statement node, or -- an operator where the corresponding subprogram is intrinsic (i.e. was diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 7ff1ea6..fb48a64 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -507,78 +507,90 @@ package body Exp_Unst is is T : constant Entity_Id := Get_Fullest_View (In_T); - procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id); + procedure Note_Uplevel_Bound (N : Node_Id); -- N is the bound of a dynamic type. This procedure notes that -- this bound is uplevel referenced, it can handle references -- to entities (typically _FIRST and _LAST entities), and also -- attribute references of the form T'name (name is typically -- FIRST or LAST) where T is the uplevel referenced bound. - -- Ref, if Present, is the location of the reference to - -- replace. ------------------------ -- Note_Uplevel_Bound -- ------------------------ - procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id) is - begin - -- Entity name case. Make sure that the entity is declared - -- in a subprogram. This may not be the case for a type in a - -- loop appearing in a precondition. - -- Exclude explicitly discriminants (that can appear - -- in bounds of discriminated components) and enumeration - -- literals. - - if Is_Entity_Name (N) then - if Present (Entity (N)) - and then not Is_Type (Entity (N)) - and then Present (Enclosing_Subprogram (Entity (N))) - and then - Ekind (Entity (N)) - not in E_Discriminant | E_Enumeration_Literal - then - Note_Uplevel_Ref - (E => Entity (N), - N => Empty, - Caller => Current_Subprogram, - Callee => Enclosing_Subprogram (Entity (N))); - end if; + procedure Note_Uplevel_Bound (N : Node_Id) is - -- Attribute or indexed component case + function Note_Uplevel_Bound_Trav + (N : Node_Id) return Traverse_Result; + -- Tree visitor that marks entities that are uplevel + -- referenced. - elsif Nkind (N) in - N_Attribute_Reference | N_Indexed_Component - then - Note_Uplevel_Bound (Prefix (N), Ref); + procedure Do_Note_Uplevel_Bound + is new Traverse_Proc (Note_Uplevel_Bound_Trav); + -- Subtree visitor instantiation - -- The indices of the indexed components, or the - -- associated expressions of an attribute reference, - -- may also involve uplevel references. + ----------------------------- + -- Note_Uplevel_Bound_Trav -- + ----------------------------- - declare - Expr : Node_Id; + function Note_Uplevel_Bound_Trav + (N : Node_Id) return Traverse_Result + is + begin + -- Entity name case. Make sure that the entity is + -- declared in a subprogram. This may not be the case for + -- a type in a loop appearing in a precondition. Exclude + -- explicitly discriminants (that can appear in bounds of + -- discriminated components), enumeration literals and + -- block. + + if Is_Entity_Name (N) then + if Present (Entity (N)) + and then not Is_Type (Entity (N)) + and then Present + (Enclosing_Subprogram (Entity (N))) + and then + Ekind (Entity (N)) + not in E_Discriminant | E_Enumeration_Literal + | E_Block + then + Note_Uplevel_Ref + (E => Entity (N), + N => Empty, + Caller => Current_Subprogram, + Callee => Enclosing_Subprogram (Entity (N))); + end if; + end if; - begin - Expr := First (Expressions (N)); - while Present (Expr) loop - Note_Uplevel_Bound (Expr, Ref); - Next (Expr); - end loop; - end; + -- N_Function_Call are handled later, don't touch them + -- yet. + if Nkind (N) in N_Function_Call + then + return Skip; + + -- In N_Selected_Component and N_Expanded_Name, only the + -- prefix may be referencing a uplevel entity. + + elsif Nkind (N) in N_Selected_Component + | N_Expanded_Name + then + Do_Note_Uplevel_Bound (Prefix (N)); + return Skip; -- The type of the prefix may be have an uplevel -- reference if this needs bounds. - if Nkind (N) = N_Attribute_Reference then + elsif Nkind (N) = N_Attribute_Reference then declare Attr : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); DT : Boolean := False; begin - if (Attr = Attribute_First - or else Attr = Attribute_Last - or else Attr = Attribute_Length) + if Attr in + Attribute_First + | Attribute_Last + | Attribute_Length and then Is_Constrained (Etype (Prefix (N))) then Check_Static_Type @@ -587,59 +599,10 @@ package body Exp_Unst is end; end if; - -- Binary operator cases. These can apply to arrays for - -- which we may need bounds. - - elsif Nkind (N) in N_Binary_Op then - Note_Uplevel_Bound (Left_Opnd (N), Ref); - Note_Uplevel_Bound (Right_Opnd (N), Ref); - - -- Unary operator case - - elsif Nkind (N) in N_Unary_Op then - Note_Uplevel_Bound (Right_Opnd (N), Ref); - - -- Explicit dereference and selected component case - - elsif Nkind (N) in - N_Explicit_Dereference | N_Selected_Component - then - Note_Uplevel_Bound (Prefix (N), Ref); - - -- Conditional expressions - - elsif Nkind (N) = N_If_Expression then - declare - Expr : Node_Id; - - begin - Expr := First (Expressions (N)); - while Present (Expr) loop - Note_Uplevel_Bound (Expr, Ref); - Next (Expr); - end loop; - end; - - elsif Nkind (N) = N_Case_Expression then - declare - Alternative : Node_Id; - - begin - Note_Uplevel_Bound (Expression (N), Ref); - - Alternative := First (Alternatives (N)); - while Present (Alternative) loop - Note_Uplevel_Bound (Expression (Alternative), Ref); - end loop; - end; - - -- Conversion case - - elsif Nkind (N) in - N_Type_Conversion | N_Unchecked_Type_Conversion - then - Note_Uplevel_Bound (Expression (N), Ref); - end if; + return OK; + end Note_Uplevel_Bound_Trav; + begin + Do_Note_Uplevel_Bound (N); end Note_Uplevel_Bound; -- Start of processing for Check_Static_Type @@ -673,12 +636,12 @@ package body Exp_Unst is begin if not Is_Static_Expression (LB) then - Note_Uplevel_Bound (LB, N); + Note_Uplevel_Bound (LB); DT := True; end if; if not Is_Static_Expression (UB) then - Note_Uplevel_Bound (UB, N); + Note_Uplevel_Bound (UB); DT := True; end if; end; @@ -704,7 +667,7 @@ package body Exp_Unst is D := First_Elmt (Discriminant_Constraint (T)); while Present (D) loop if not Is_Static_Expression (Node (D)) then - Note_Uplevel_Bound (Node (D), N); + Note_Uplevel_Bound (Node (D)); DT := True; end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 8e5cdb7..9b67384 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5049,23 +5049,17 @@ package body Exp_Util is --------------------------------- function Duplicate_Subexpr_No_Checks - (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False; - Related_Id : Entity_Id := Empty; - Is_Low_Bound : Boolean := False; - Is_High_Bound : Boolean := False) return Node_Id + (Exp : Node_Id; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is New_Exp : Node_Id; begin Remove_Side_Effects - (Exp => Exp, - Name_Req => Name_Req, - Renaming_Req => Renaming_Req, - Related_Id => Related_Id, - Is_Low_Bound => Is_Low_Bound, - Is_High_Bound => Is_High_Bound); + (Exp => Exp, + Name_Req => Name_Req, + Renaming_Req => Renaming_Req); New_Exp := New_Copy_Tree (Exp); Remove_Checks (New_Exp); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 279feb2..49e75c7 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -457,24 +457,14 @@ package Exp_Util is -- following functions allow this behavior to be modified. function Duplicate_Subexpr_No_Checks - (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False; - Related_Id : Entity_Id := Empty; - Is_Low_Bound : Boolean := False; - Is_High_Bound : Boolean := False) return Node_Id; + (Exp : Node_Id; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is -- called on the result, so that the duplicated expression does not include -- checks. This is appropriate for use when Exp, the original expression is -- unconditionally elaborated before the duplicated expression, so that -- there is no need to repeat any checks. - -- - -- Related_Id denotes the entity of the context where Expr appears. Flags - -- Is_Low_Bound and Is_High_Bound specify whether the expression to check - -- is the low or the high bound of a range. These three optional arguments - -- signal Remove_Side_Effects to create an external symbol of the form - -- Chars (Related_Id)_FIRST/_LAST. For suggested use of these parameters - -- see the warning in the body of Sem_Ch3.Process_Range_Expr_In_Decl. function Duplicate_Subexpr_Move_Checks (Exp : Node_Id; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index b284110..1174eb1 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -309,6 +309,16 @@ GNAT_ADA_OBJS = \ ada/cstand.o \ ada/debug.o \ ada/debug_a.o \ + ada/diagnostics-brief_emitter.o \ + ada/diagnostics-constructors.o \ + ada/diagnostics-converter.o \ + ada/diagnostics-json_utils.o \ + ada/diagnostics-pretty_emitter.o \ + ada/diagnostics-repository.o \ + ada/diagnostics-sarif_emitter.o \ + ada/diagnostics-switch_repository.o \ + ada/diagnostics-utils.o \ + ada/diagnostics.o \ ada/einfo-entities.o \ ada/einfo-utils.o \ ada/einfo.o \ @@ -594,6 +604,16 @@ GNATBIND_OBJS = \ ada/casing.o \ ada/csets.o \ ada/debug.o \ + ada/diagnostics-brief_emitter.o \ + ada/diagnostics-constructors.o \ + ada/diagnostics-converter.o \ + ada/diagnostics-json_utils.o \ + ada/diagnostics-pretty_emitter.o \ + ada/diagnostics-repository.o \ + ada/diagnostics-sarif_emitter.o \ + ada/diagnostics-switch_repository.o \ + ada/diagnostics-utils.o \ + ada/diagnostics.o \ ada/einfo-entities.o \ ada/einfo-utils.o \ ada/einfo.o \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 29db89c..12f9d65 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -334,6 +334,16 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \ switch.o switch-m.o table.o targparm.o tempdir.o types.o uintp.o \ uname.o urealp.o usage.o widechar.o warnsw.o \ seinfo.o einfo-entities.o einfo-utils.o sinfo-nodes.o sinfo-utils.o \ + diagnostics-brief_emitter.o \ + diagnostics-constructors.o \ + diagnostics-converter.o \ + diagnostics-json_utils.o \ + diagnostics-pretty_emitter.o \ + diagnostics-repository.o \ + diagnostics-sarif_emitter.o \ + diagnostics-switch_repository.o \ + diagnostics-utils.o \ + diagnostics.o \ $(EXTRA_GNATMAKE_OBJS) # Make arch match the current multilib so that the RTS selection code diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index d7c1723..4252e62 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -521,8 +521,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) esize = UI_To_Int (Esize (gnat_entity)); if (IN (kind, Float_Kind)) +#ifdef WIDEST_HARDWARE_FP_SIZE + max_esize = fp_prec_to_size (WIDEST_HARDWARE_FP_SIZE); +#else max_esize = fp_prec_to_size (TYPE_PRECISION (long_double_type_node)); +#endif else if (IN (kind, Access_Kind)) max_esize = POINTER_SIZE * 2; else @@ -1426,7 +1430,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) post_error ("??too large object cannot be allocated statically", gnat_entity); - post_error ("\\?dynamic allocation will be used instead", + post_error ("\\??dynamic allocation will be used instead", gnat_entity); } @@ -6561,7 +6565,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, ("??cannot import type-generic 'G'C'C builtin!", gnat_subprog); post_error - ("\\?use a supported result type", + ("\\??use a supported result type", gnat_subprog); gnu_builtin_decl = NULL_TREE; } @@ -6583,7 +6587,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, ("??cannot import type-generic 'G'C'C builtin!", gnat_subprog); post_error - ("\\?use a supported second parameter type", + ("\\??use a supported second parameter type", gnat_subprog); gnu_builtin_decl = NULL_TREE; } @@ -6604,7 +6608,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, ("??cannot import type-generic 'G'C'C builtin!", gnat_subprog); post_error - ("\\?use a supported third parameter type", + ("\\??use a supported third parameter type", gnat_subprog); gnu_builtin_decl = NULL_TREE; } @@ -7682,6 +7686,8 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, gnu_field_type = gnu_packable_type; if (!gnu_size) gnu_size = rm_size (gnu_field_type); + if (TREE_CODE (gnu_size) != INTEGER_CST) + gnu_size = NULL_TREE; } } diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 40f3f0d..f4b302b 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -1008,6 +1008,10 @@ extern bool must_pass_by_ref (tree gnu_type); /* Return the size of the FP mode with precision PREC. */ extern int fp_prec_to_size (int prec); +/* Return the default alignment of a FIELD of TYPE declared in a record or + union type as specified by the ABI of the target architecture. */ +extern unsigned int default_field_alignment (tree field, tree type); + /* Return the precision of the FP mode with size SIZE. */ extern int fp_size_to_prec (int size); diff --git a/gcc/ada/gcc-interface/lang.opt.urls b/gcc/ada/gcc-interface/lang.opt.urls index 7913bcb..3174c22 100644 --- a/gcc/ada/gcc-interface/lang.opt.urls +++ b/gcc/ada/gcc-interface/lang.opt.urls @@ -7,10 +7,10 @@ UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Opti ; duplicate: 'gcc/Standard-Libraries.html#index-Wall-1' ; duplicate: 'gcc/Warning-Options.html#index-Wall' Wall -LangUrlSuffix_D(gdc/Warnings.html#index-Wall) +LangUrlSuffix_D(gdc/Warnings.html#index-Wall) LangUrlSuffix_Fortran(gfortran/Error-and-Warning-Options.html#index-Wall) nostdinc -UrlSuffix(gcc/Directory-Options.html#index-nostdinc) LangUrlSuffix_D(gdc/Directory-Options.html#index-nostdinc) +UrlSuffix(gcc/Directory-Options.html#index-nostdinc) LangUrlSuffix_D(gdc/Directory-Options.html#index-nostdinc) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-nostdinc) nostdlib UrlSuffix(gcc/Link-Options.html#index-nostdlib) @@ -19,6 +19,8 @@ UrlSuffix(gcc/Link-Options.html#index-nostdlib) ; duplicate: 'gcc/Code-Gen-Options.html#index-fshort-enums' ; duplicate: 'gcc/Non-bugs.html#index-fshort-enums-3' ; duplicate: 'gcc/Structures-unions-enumerations-and-bit-fields-implementation.html#index-fshort-enums-1' +fshort-enums +LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fshort-enums) ; skipping UrlSuffix for 'fsigned-char' due to multiple URLs: ; duplicate: 'gcc/C-Dialect-Options.html#index-fsigned-char' diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc index 13cb39e..2aa1bfd 100644 --- a/gcc/ada/gcc-interface/misc.cc +++ b/gcc/ada/gcc-interface/misc.cc @@ -28,6 +28,8 @@ #include "coretypes.h" #include "target.h" #include "tree.h" +#include "memmodel.h" +#include "tm_p.h" #include "diagnostic.h" #include "opts.h" #include "alias.h" @@ -305,14 +307,14 @@ internal_error_function (diagnostic_context *context, const char *msgid, emergency_dump_function (); /* Reset the pretty-printer. */ - pp_clear_output_area (context->printer); + pp_clear_output_area (context->m_printer); /* Format the message into the pretty-printer. */ text_info tinfo (msgid, ap, errno); - pp_format_verbatim (context->printer, &tinfo); + pp_format_verbatim (context->m_printer, &tinfo); /* Extract a (writable) pointer to the formatted text. */ - buffer = xstrdup (pp_formatted_text (context->printer)); + buffer = xstrdup (pp_formatted_text (context->m_printer)); /* Go up to the first newline. */ for (p = buffer; *p; p++) @@ -1129,6 +1131,26 @@ must_pass_by_ref (tree gnu_type) && TREE_CODE (TYPE_SIZE_UNIT (gnu_type)) != INTEGER_CST)); } +/* Return the default alignment of a FIELD of TYPE declared in a record or + union type as specified by the ABI of the target architecture. */ + +unsigned int +default_field_alignment (tree ARG_UNUSED (field), tree type) +{ + /* This is modeled on layout_decl. */ + unsigned int align = TYPE_ALIGN (type); + +#ifdef BIGGEST_FIELD_ALIGNMENT + align = MIN (align, (unsigned int) BIGGEST_FIELD_ALIGNMENT); +#endif + +#ifdef ADJUST_FIELD_ALIGN + align = ADJUST_FIELD_ALIGN (field, type, align); +#endif + + return align; +} + /* This function is called by the front-end to enumerate all the supported modes for the machine, as well as some predefined C types. F is a function which is called back with the parameters as listed below, first a string, diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index 3f2eadd..710907b 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -4387,9 +4387,9 @@ get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync) gnat_node = Expression (gnat_node); /* Up to Ada 2012, for Atomic itself, only reads and updates of the object as - a whole require atomic access (RM C.6(15)). But, starting with Ada 2022, - reads of or writes to a nonatomic subcomponent of the object also require - atomic access (RM C.6(19)). */ + a whole require atomic access (RM C.6(15)), unless the object is also VFA. + But, starting with Ada 2022, reads of or writes to nonatomic subcomponents + of the object also require atomic access (RM C.6(19)). */ if (node_is_atomic (gnat_node)) { bool as_a_whole = true; @@ -4398,7 +4398,9 @@ get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync) for (gnat_temp = gnat_node, gnat_parent = Parent (gnat_temp); node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_temp; gnat_temp = gnat_parent, gnat_parent = Parent (gnat_temp)) - if (Ada_Version < Ada_2022 || node_is_atomic (gnat_parent)) + if (Ada_Version < Ada_2022 + ? !node_is_volatile_full_access (gnat_node) + : node_is_atomic (gnat_parent)) goto not_atomic; else as_a_whole = false; @@ -4525,6 +4527,9 @@ storage_model_access_required_p (Node_Id gnat_node, Entity_Id *gnat_smo) static tree create_temporary (const char *prefix, tree type) { + if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (type))) + type = maybe_pad_type (type, max_size (TYPE_SIZE (type), true), 0, + Empty, false, false, true); tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE, type, NULL_TREE, @@ -4944,10 +4949,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, ("unchecked conversion implemented by copy??", gnat_actual); post_error - ("\\?use pragma Universal_Aliasing on either type", + ("\\??use pragma Universal_Aliasing on either type", gnat_actual); post_error - ("\\?to enable RM 13.9(12) implementation permission", + ("\\??to enable RM 13.9(12) implementation permission", gnat_actual); } @@ -4957,10 +4962,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, ("value conversion implemented by copy??", gnat_actual); post_error - ("\\?use pair of types with same root type", + ("\\??use pair of types with same root type", gnat_actual); post_error - ("\\?to avoid new object in RM 4.6(58.5/5)", + ("\\??to avoid new object in RM 4.6(58.5/5)", gnat_actual); } } @@ -10286,12 +10291,18 @@ addressable_p (tree gnu_expr, tree gnu_type) /* Even with DECL_BIT_FIELD cleared, we have to ensure that the field is sufficiently aligned, in case it is subject to a pragma Component_Alignment. But we don't need to - check the alignment of the containing record, as it is - guaranteed to be not smaller than that of its most - aligned field that is not a bit-field. */ - && (!STRICT_ALIGNMENT - || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) - >= TYPE_ALIGN (TREE_TYPE (gnu_expr)))) + check the alignment of the containing record, since it + is guaranteed to be not smaller than that of its most + aligned field that is not a bit-field. However, we need + to cope with quirks of ABIs that may misalign fields. */ + && (DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) + >= default_field_alignment (TREE_OPERAND (gnu_expr, 1), + TREE_TYPE (gnu_expr)) + /* We do not enforce this on strict-alignment platforms for + internal fields in order to keep supporting misalignment + of tagged types in legacy code. */ + || (!STRICT_ALIGNMENT + && DECL_INTERNAL_P (TREE_OPERAND (gnu_expr, 1))))) /* The field of a padding record is always addressable. */ || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); @@ -10633,9 +10644,9 @@ validate_unchecked_conversion (Node_Id gnat_node) { post_error_ne ("??possible aliasing problem for type&", gnat_node, Target_Type (gnat_node)); - post_error ("\\?use -fno-strict-aliasing switch for references", + post_error ("\\??use -fno-strict-aliasing switch for references", gnat_node); - post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`", + post_error_ne ("\\??or use `pragma No_Strict_Aliasing (&);`", gnat_node, Target_Type (gnat_node)); } } @@ -10659,7 +10670,7 @@ validate_unchecked_conversion (Node_Id gnat_node) { post_error_ne ("??possible aliasing problem for type&", gnat_node, Target_Type (gnat_node)); - post_error ("\\?use -fno-strict-aliasing switch for references", + post_error ("\\??use -fno-strict-aliasing switch for references", gnat_node); } } diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index 66e3192..60f36b1 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -2220,7 +2220,7 @@ finish_record_type (tree record_type, tree field_list, int rep_level, if (DECL_BIT_FIELD (field) && operand_equal_p (this_size, TYPE_SIZE (type), 0)) { - const unsigned int align = TYPE_ALIGN (type); + const unsigned int align = default_field_alignment (field, type); /* In the general case, type alignment is required. */ if (value_factor_p (pos, align)) diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index f901b0e..4ef631f 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Aug 26, 2024 +GNAT Reference Manual , Aug 30, 2024 AdaCore @@ -912,6 +912,7 @@ Experimental Language Extensions * Case pattern matching:: * Mutably Tagged Types with Size’Class Aspect:: * Generalized Finalization:: +* Inference of Dependent Types in Generic Instantiations:: Security Hardening Features @@ -28925,7 +28926,8 @@ activate the curated subset of extensions. @cartouche @quotation Attention -You can activate the extended set of extensions by using either +You can activate the experimental set of extensions +in addition by using either the @code{-gnatX0} command line flag, or the pragma @code{Extensions_Allowed} with @code{All_Extensions} as an argument. However, it is not recommended you use this subset for serious projects; it is only meant as a technology preview @@ -28938,6 +28940,9 @@ for use in playground experiments. @section Curated Extensions +Features activated via @code{-gnatX} or +@code{pragma Extensions_Allowed (On)}. + @menu * Local Declarations Without Block:: * Fixed lower bounds for array types and subtypes:: @@ -29370,6 +29375,9 @@ Link to the original RFC: @section Experimental Language Extensions +Features activated via @code{-gnatX0} or +@code{pragma Extensions_Allowed (All_Extensions)}. + @menu * Conditional when constructs:: * Storage Model:: @@ -29378,6 +29386,7 @@ Link to the original RFC: * Case pattern matching:: * Mutably Tagged Types with Size’Class Aspect:: * Generalized Finalization:: +* Inference of Dependent Types in Generic Instantiations:: @end menu @@ -29683,7 +29692,7 @@ subcomponents, among others detailed in the RFC. Link to the original RFC: @indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/topic/rfc-finally/considered/rfc-class-size.md} -@node Generalized Finalization,,Mutably Tagged Types with Size’Class Aspect,Experimental Language Extensions +@node Generalized Finalization,Inference of Dependent Types in Generic Instantiations,Mutably Tagged Types with Size’Class Aspect,Experimental Language Extensions @anchor{gnat_rm/gnat_language_extensions generalized-finalization}@anchor{454} @subsection Generalized Finalization @@ -29715,8 +29724,88 @@ procedure Initialize (Obj : in out Ctrl); Link to the original RFC: @indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/topic/finalization-rehaul/considered/rfc-generalized-finalization.md} +@node Inference of Dependent Types in Generic Instantiations,,Generalized Finalization,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions inference-of-dependent-types-in-generic-instantiations}@anchor{455} +@subsection Inference of Dependent Types in Generic Instantiations + + +If a generic formal type T2 depends on another formal type T1, +the actual for T1 can be inferred from the actual for T2. +That is, you can give the actual for T2, and leave out the one +for T1. + +For example, @code{Ada.Unchecked_Deallocation} has two generic formals: + +@example +generic + type Object (<>) is limited private; + type Name is access Object; +procedure Ada.Unchecked_Deallocation (X : in out Name); +@end example + +where @code{Name} depends on @code{Object}. With this language extension, +you can leave out the actual for @code{Object}, as in: + +@example +type Integer_Access is access all Integer; + +procedure Free is new Unchecked_Deallocation (Name => Integer_Access); +@end example + +The compiler will infer that the actual type for @code{Object} is @code{Integer}. +Note that named notation is always required when using inference. + +The following inferences are allowed: + + +@itemize - + +@item +For a formal access type, the designated type can be inferred. + +@item +For a formal array type, the index type(s) and the component +type can be inferred. + +@item +For a formal type with discriminats, the type(s) of the discriminants +can be inferred. +@end itemize + +Example for arrays: + +@example +generic + type Element_Type is private; + type Index_Type is (<>); + type Array_Type is array (Index_Type range <>) of Element_Type; +package Array_Operations is + ... +end Array_Operations; + +... + +type Int_Array is array (Positive range <>) of Integer; + +package Int_Array_Operations is new Array_Operations (Array_Type => Int_Array); +@end example + +The index and component types of @code{Array_Type} are inferred from +@code{Int_Array}, so that the above instantiation is equivalent to +the following standard-Ada instantiation: + +@example +package Int_Array_Operations is new Array_Operations + (Element_Type => Integer, + Index_Type => Positive, + Array_Type => Int_Array); +@end example + +Link to the original RFC: +@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/topic/generic_instantiations/considered/rfc-inference-of-dependent-types.md} + @node Security Hardening Features,Obsolescent Features,GNAT language extensions,Top -@anchor{gnat_rm/security_hardening_features doc}@anchor{455}@anchor{gnat_rm/security_hardening_features id1}@anchor{456}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} +@anchor{gnat_rm/security_hardening_features doc}@anchor{456}@anchor{gnat_rm/security_hardening_features id1}@anchor{457}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} @chapter Security Hardening Features @@ -29738,7 +29827,7 @@ change. @end menu @node Register Scrubbing,Stack Scrubbing,,Security Hardening Features -@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{457} +@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{458} @section Register Scrubbing @@ -29774,7 +29863,7 @@ programming languages, see @cite{Using the GNU Compiler Collection (GCC)}. @c Stack Scrubbing: @node Stack Scrubbing,Hardened Conditionals,Register Scrubbing,Security Hardening Features -@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{458} +@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{459} @section Stack Scrubbing @@ -29918,7 +30007,7 @@ Bar_Callable_Ptr. @c Hardened Conditionals: @node Hardened Conditionals,Hardened Booleans,Stack Scrubbing,Security Hardening Features -@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{459} +@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{45a} @section Hardened Conditionals @@ -30008,7 +30097,7 @@ be used with other programming languages supported by GCC. @c Hardened Booleans: @node Hardened Booleans,Control Flow Redundancy,Hardened Conditionals,Security Hardening Features -@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{45a} +@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{45b} @section Hardened Booleans @@ -30069,7 +30158,7 @@ and more details on that attribute, see @cite{Using the GNU Compiler Collection @c Control Flow Redundancy: @node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features -@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{45b} +@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{45c} @section Control Flow Redundancy @@ -30237,7 +30326,7 @@ see @cite{Using the GNU Compiler Collection (GCC)}. These options can be used with other programming languages supported by GCC. @node Obsolescent Features,Compatibility and Porting Guide,Security Hardening Features,Top -@anchor{gnat_rm/obsolescent_features doc}@anchor{45c}@anchor{gnat_rm/obsolescent_features id1}@anchor{45d}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} +@anchor{gnat_rm/obsolescent_features doc}@anchor{45d}@anchor{gnat_rm/obsolescent_features id1}@anchor{45e}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} @chapter Obsolescent Features @@ -30256,7 +30345,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{45e}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{45f} +@anchor{gnat_rm/obsolescent_features id2}@anchor{45f}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{460} @section pragma No_Run_Time @@ -30269,7 +30358,7 @@ preferred usage is to use an appropriately configured run-time that includes just those features that are to be made accessible. @node pragma Ravenscar,pragma Restricted_Run_Time,pragma No_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id3}@anchor{460}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{461} +@anchor{gnat_rm/obsolescent_features id3}@anchor{461}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{462} @section pragma Ravenscar @@ -30278,7 +30367,7 @@ The pragma @code{Ravenscar} has exactly the same effect as pragma is part of the new Ada 2005 standard. @node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id4}@anchor{462}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{463} +@anchor{gnat_rm/obsolescent_features id4}@anchor{463}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{464} @section pragma Restricted_Run_Time @@ -30288,7 +30377,7 @@ preferred since the Ada 2005 pragma @code{Profile} is intended for this kind of implementation dependent addition. @node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id5}@anchor{464}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{465} +@anchor{gnat_rm/obsolescent_features id5}@anchor{465}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{466} @section pragma Task_Info @@ -30314,7 +30403,7 @@ in the spec of package System.Task_Info in the runtime library. @node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features -@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{466}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{467} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{467}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{468} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -30324,7 +30413,7 @@ to support the @code{Task_Info} pragma. The predefined Ada package standard replacement for GNAT’s @code{Task_Info} functionality. @node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top -@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{468}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{469} +@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{469}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{46a} @chapter Compatibility and Porting Guide @@ -30346,7 +30435,7 @@ applications developed in other Ada environments. @end menu @node Writing Portable Fixed-Point Declarations,Compatibility with Ada 83,,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{46a}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{46b} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{46b}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{46c} @section Writing Portable Fixed-Point Declarations @@ -30468,7 +30557,7 @@ If you follow this scheme you will be guaranteed that your fixed-point types will be portable. @node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{46c}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{46d} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{46d}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{46e} @section Compatibility with Ada 83 @@ -30496,7 +30585,7 @@ following subsections treat the most likely issues to be encountered. @end menu @node Legal Ada 83 programs that are illegal in Ada 95,More deterministic semantics,,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{46e}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{46f} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{46f}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{470} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -30596,7 +30685,7 @@ the fix is usually simply to add the @code{(<>)} to the generic declaration. @end itemize @node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{470}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{471} +@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{471}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{472} @subsection More deterministic semantics @@ -30624,7 +30713,7 @@ which open select branches are executed. @end itemize @node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{472}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{473} +@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{473}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{474} @subsection Changed semantics @@ -30666,7 +30755,7 @@ covers only the restricted range. @end itemize @node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{474}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{475} +@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{475}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{476} @subsection Other language compatibility issues @@ -30699,7 +30788,7 @@ include @code{pragma Interface} and the floating point type attributes @end itemize @node Compatibility between Ada 95 and Ada 2005,Implementation-dependent characteristics,Compatibility with Ada 83,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{476}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{477} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{477}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{478} @section Compatibility between Ada 95 and Ada 2005 @@ -30771,7 +30860,7 @@ can declare a function returning a value from an anonymous access type. @end itemize @node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{478}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{479} +@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{479}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{47a} @section Implementation-dependent characteristics @@ -30794,7 +30883,7 @@ transition from certain Ada 83 compilers. @end menu @node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{47a}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{47b} +@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{47b}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{47c} @subsection Implementation-defined pragmas @@ -30816,7 +30905,7 @@ avoiding compiler rejection of units that contain such pragmas; they are not relevant in a GNAT context and hence are not otherwise implemented. @node Implementation-defined attributes,Libraries,Implementation-defined pragmas,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{47c}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{47d} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{47d}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{47e} @subsection Implementation-defined attributes @@ -30830,7 +30919,7 @@ Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and @code{Type_Class}. @node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{47e}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{47f} +@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{47f}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{480} @subsection Libraries @@ -30859,7 +30948,7 @@ be preferable to retrofit the application using modular types. @end itemize @node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{480}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{481} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{481}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{482} @subsection Elaboration order @@ -30895,7 +30984,7 @@ pragmas either globally (as an effect of the `-gnatE' switch) or locally @end itemize @node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{482}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{483} +@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{483}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{484} @subsection Target-specific aspects @@ -30908,10 +30997,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus Ada 2005 and Ada 2012) are sometimes incompatible with typical Ada 83 compiler practices regarding implicit packing, the meaning of the Size attribute, and the size of access values. -GNAT’s approach to these issues is described in @ref{484,,Representation Clauses}. +GNAT’s approach to these issues is described in @ref{485,,Representation Clauses}. @node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{485}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{486} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{486}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{487} @section Compatibility with Other Ada Systems @@ -30954,7 +31043,7 @@ far beyond this minimal set, as described in the next section. @end itemize @node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{487}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{484} +@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{488}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{485} @section Representation Clauses @@ -31047,7 +31136,7 @@ with thin pointers. @end itemize @node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{488}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{489} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{489}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{48a} @section Compatibility with HP Ada 83 @@ -31077,7 +31166,7 @@ extension of package System. @end itemize @node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top -@anchor{share/gnu_free_documentation_license doc}@anchor{48a}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{48b} +@anchor{share/gnu_free_documentation_license doc}@anchor{48b}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{48c} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 27c705e..e59ee9f 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Aug 26, 2024 +GNAT User's Guide for Native Platforms , Aug 30, 2024 AdaCore @@ -11678,7 +11678,7 @@ This switch suppresses listing of inherited aspects. @item @code{-gnatw_l} -`Activate warnings on inheritely limited types.' +`Activate warnings on implicitly limited types.' This switch causes the compiler trigger warnings on record types that do not have a limited keyword but contain a component that is a limited type. @@ -11691,9 +11691,9 @@ have a limited keyword but contain a component that is a limited type. @item @code{-gnatw_L} -`Suppress warnings on inheritely limited types.' +`Suppress warnings on implicitly limited types.' -This switch suppresses warnings on inheritely limited types. +This switch suppresses warnings on implicitly limited types. @end table @geindex -gnatwm (gcc) @@ -13481,7 +13481,7 @@ in the string after @code{-gnaty} then proper indentation is checked, with the digit indicating the indentation level required. A value of zero turns off this style check. The rule checks that the following constructs start on a column that is -a multiple of the alignment level: +one plus a multiple of the alignment level: @itemize * @@ -13499,10 +13499,10 @@ or body or that completes a compound statement. @end itemize Full line comments must be -aligned with the @code{--} starting on a column that is a multiple of +aligned with the @code{--} starting on a column that is one plus a multiple of the alignment level, or they may be aligned the same way as the following non-blank line (this is useful when full line comments appear in the middle -of a statement, or they may be aligned with the source line on the previous +of a statement), or they may be aligned with the source line on the previous non-blank line. @end table @@ -29695,8 +29695,8 @@ to permit their use in free software. @printindex ge -@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @anchor{d1}@w{ } +@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @c %**end of body @bye diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index c1b817b..ed37a34 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -278,7 +278,8 @@ procedure GNATCmd is -- Start of processing for GNATCmd begin - -- All output from GNATCmd is debugging or error output: send to stderr + -- Almost all output from GNATCmd is debugging or error output: send to + -- stderr. Set_Standard_Error; @@ -349,6 +350,7 @@ begin elsif Command_Arg <= Argument_Count and then Argument (Command_Arg) = Ada_Help_Switch then + Set_Standard_Output; Usage; Exit_Program (E_Success); @@ -364,6 +366,7 @@ begin -- Add the following so that output is consistent with or without the -- --help flag. + Set_Standard_Output; Write_Eol; Write_Line ("Report bugs to report@adacore.com"); return; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 519e26e..5f310ab 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -2136,8 +2136,6 @@ package body Inline is end; end if; - pragma Assert (Msg (Msg'Last) = '?'); - -- Legacy front-end inlining model if not Back_End_Inlining then diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index bc90c0c..696f422 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -165,7 +165,10 @@ package Inline is N : Node_Id; Subp : Entity_Id; Is_Serious : Boolean := False; - Suppress_Info : Boolean := False); + Suppress_Info : Boolean := False) + with + Pre => Msg'First <= Msg'Last + and then Msg (Msg'Last) = '?'; -- This procedure is called if the node N, an instance of a call to -- subprogram Subp, cannot be inlined. Msg is the message to be issued, -- which ends with ? (it does not end with ?p?, this routine takes care of diff --git a/gcc/ada/libgnat/g-lists.adb b/gcc/ada/libgnat/g-lists.adb index cf118ab..5624df0 100644 --- a/gcc/ada/libgnat/g-lists.adb +++ b/gcc/ada/libgnat/g-lists.adb @@ -332,7 +332,7 @@ package body GNAT.Lists is -- The list has at least one outstanding iterator - if L.Iterators > 0 then + if Check_Tampering and then L.Iterators > 0 then raise Iterated; end if; end Ensure_Unlocked; diff --git a/gcc/ada/libgnat/g-lists.ads b/gcc/ada/libgnat/g-lists.ads index 4745913..1a3c18e 100644 --- a/gcc/ada/libgnat/g-lists.ads +++ b/gcc/ada/libgnat/g-lists.ads @@ -64,6 +64,8 @@ package GNAT.Lists is with procedure Destroy_Element (Elem : in out Element_Type); -- Element destructor + Check_Tampering : Boolean := True; + package Doubly_Linked_Lists is --------------------- diff --git a/gcc/ada/libgnat/s-os_lib.ads b/gcc/ada/libgnat/s-os_lib.ads index 46e11f7..54e7205 100644 --- a/gcc/ada/libgnat/s-os_lib.ads +++ b/gcc/ada/libgnat/s-os_lib.ads @@ -130,12 +130,12 @@ package System.OS_Lib is -- Returns current local time in the form YYYY-MM-DD HH:MM:SS. The result -- has bounds 1 .. 19. - function GM_Year (Date : OS_Time) return Year_Type; - function GM_Month (Date : OS_Time) return Month_Type; - function GM_Day (Date : OS_Time) return Day_Type; - function GM_Hour (Date : OS_Time) return Hour_Type; - function GM_Minute (Date : OS_Time) return Minute_Type; - function GM_Second (Date : OS_Time) return Second_Type; + function GM_Year (Date : OS_Time) return Year_Type; + function GM_Month (Date : OS_Time) return Month_Type; + function GM_Day (Date : OS_Time) return Day_Type; + function GM_Hour (Date : OS_Time) return Hour_Type; + function GM_Minute (Date : OS_Time) return Minute_Type; + function GM_Second (Date : OS_Time) return Second_Type; -- Functions to extract information from OS_Time value in GMT form procedure GM_Split diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index dd0c8b3..aea52f3 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1340,6 +1340,19 @@ package Opt is -- GNATMAKE, GNATLINK -- Set to False when no run_path_option should be issued to the linker + SARIF_File : Boolean := False; + -- GNAT + -- Output error and warning messages in SARIF format. Set to true when the + -- backend option "-fdiagnostics-format=sarif-file" is found on the + -- command line. The SARIF file is written to the file named: + -- <source_file>.gnat.sarif + + SARIF_Output : Boolean := False; + -- GNAT + -- Output error and warning messages in SARIF format. Set to true when the + -- backend option "-fdiagnostics-format=sarif-stderr" is found on the + -- command line. + Search_Directory_Present : Boolean := False; -- GNAT -- Set to True when argument is -I. Reset to False when next argument, a diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 0345f80..ec8acbb 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -28,6 +28,7 @@ with Stringt; use Stringt; with Uintp; use Uintp; with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; +with Diagnostics.Constructors; use Diagnostics.Constructors; separate (Par) package body Endh is @@ -896,6 +897,8 @@ package body Endh is procedure Output_End_Expected (Ins : Boolean) is End_Type : SS_End_Type; + Wrong_End_Start : Source_Ptr; + Wrong_End_Finish : Source_Ptr; begin -- Suppress message if this was a potentially junk entry (e.g. a record -- entry where no record keyword was present). @@ -932,8 +935,32 @@ package body Endh is elsif End_Type = E_Loop then if Error_Msg_Node_1 = Empty then - Error_Msg_SC -- CODEFIX - ("`END LOOP;` expected@ for LOOP#!"); + + if Debug_Flag_Underscore_DD then + + -- TODO: This is a quick hack to get the location of the + -- END LOOP for the demonstration. + + Wrong_End_Start := Token_Ptr; + + while Token /= Tok_Semicolon loop + Scan; -- past semicolon + end loop; + + Wrong_End_Finish := Token_Ptr; + + Restore_Scan_State (Scan_State); + + Record_End_Loop_Expected_Error + (End_Loc => To_Span (First => Wrong_End_Start, + Ptr => Wrong_End_Start, + Last => Wrong_End_Finish), + Start_Loc => Error_Msg_Sloc); + + else + Error_Msg_SC -- CODEFIX + ("`END LOOP;` expected@ for LOOP#!"); + end if; else Error_Msg_SC -- CODEFIX ("`END LOOP &;` expected@!"); diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 946da34..96eb99d 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -1997,8 +1997,10 @@ CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock") CNS(CLOCK_RT_Ada, "") #endif -#if defined (__APPLE__) || defined (__linux__) || defined (__ANDROID__) \ - || defined (__QNX__) || defined (__rtems__) || defined (DUMMY) +#if defined (__APPLE__) || defined (__ANDROID__) || defined (DUMMY) \ + || defined (__FreeBSD__) || defined (__linux__) \ + || defined (__QNX__) || defined (__rtems__) + /* -- Sizes of pthread data types @@ -2041,7 +2043,8 @@ CND(PTHREAD_RWLOCKATTR_SIZE, "pthread_rwlockattr_t") CND(PTHREAD_RWLOCK_SIZE, "pthread_rwlock_t") CND(PTHREAD_ONCE_SIZE, "pthread_once_t") -#endif /* __APPLE__ || __linux__ || __ANDROID__ || __rtems__ */ +#endif /* __APPLE__ || __ANDROID__ || __FreeBSD ||__linux__ + || __QNX__|| __rtems__ */ /* diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 8319ff5..63bdeca 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -301,7 +301,7 @@ package body Sem_Aggr is -- In addition this step analyzes and resolves each discrete_choice, -- making sure that its type is the type of the corresponding Index. -- If we are not at the lowest array aggregate level (in the case of - -- multi-dimensional aggregates) then invoke Resolve_Array_Aggregate + -- multidimensional aggregates) then invoke Resolve_Array_Aggregate -- recursively on each component expression. Otherwise, resolve the -- bottom level component expressions against the expected component -- type ONLY IF the component corresponds to a single discrete choice @@ -314,7 +314,7 @@ package body Sem_Aggr is -- 3. For positional aggregates: -- -- (A) Loop over the component expressions either recursively invoking - -- Resolve_Array_Aggregate on each of these for multi-dimensional + -- Resolve_Array_Aggregate on each of these for multidimensional -- array aggregates or resolving the bottom level component -- expressions against the expected component type. -- @@ -1596,6 +1596,8 @@ package body Sem_Aggr is Nb_Choices : Nat := 0; -- Contains the overall number of named choices in this sub-aggregate + Saved_SED : constant Nat := Serious_Errors_Detected; + function Add (Val : Uint; To : Node_Id) return Node_Id; -- Creates a new expression node where Val is added to expression To. -- Tries to constant fold whenever possible. To must be an already @@ -1968,7 +1970,7 @@ package body Sem_Aggr is Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr); -- Index is the current index corresponding to the expression - Resolution_OK : Boolean := True; + Resolution_OK : Boolean := True; -- Set to False if resolution of the expression failed begin @@ -2038,6 +2040,9 @@ package body Sem_Aggr is Resolution_OK := Resolve_Array_Aggregate (Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed); + if Resolution_OK = Failure then + return Failure; + end if; else -- If it's "... => <>", nothing to resolve @@ -2135,10 +2140,10 @@ package body Sem_Aggr is -- Local variables - Choice : Node_Id; - Dummy : Boolean; - Scop : Entity_Id; - Expr : constant Node_Id := Expression (N); + Choice : Node_Id; + Resolution_OK : Boolean; + Scop : Entity_Id; + Expr : constant Node_Id := Expression (N); -- Start of processing for Resolve_Iterated_Component_Association @@ -2208,7 +2213,11 @@ package body Sem_Aggr is -- rewritting as a loop with a new index variable; when not -- generating code we leave the analyzed expression as it is. - Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False); + Resolution_OK := Resolve_Aggr_Expr (Expr, Single_Elmt => False); + + if not Resolution_OK then + return; + end if; if Operating_Mode /= Check_Semantics then Remove_References (Expr); @@ -2610,6 +2619,14 @@ package body Sem_Aggr is if Nkind (Assoc) = N_Iterated_Component_Association and then Present (Iterator_Specification (Assoc)) then + if Number_Dimensions (Etype (N)) /= 1 then + Error_Msg_N ("iterated_component_association with an" & + " iterator_specification not allowed for" & + " multidimensional array aggregate", + Assoc); + return Failure; + end if; + -- All other component associations must have an iterator spec. Next (Assoc); @@ -2931,16 +2948,75 @@ package body Sem_Aggr is Get_Index_Bounds (Choice, Low, High); end if; - if (Dynamic_Or_Null_Range (Low, High) - or else (Nkind (Choice) = N_Subtype_Indication - and then - Dynamic_Or_Null_Range (S_Low, S_High))) - and then Nb_Choices /= 1 + if Dynamic_Or_Null_Range (Low, High) + or else (Nkind (Choice) = N_Subtype_Indication + and then Dynamic_Or_Null_Range (S_Low, S_High)) then - Error_Msg_N - ("dynamic or empty choice in aggregate " - & "must be the only choice", Choice); - return Failure; + if Nb_Choices /= 1 then + Error_Msg_N + ("dynamic or empty choice in aggregate " + & "must be the only choice", Choice); + return Failure; + elsif Number_Dimensions (Etype (N)) > 1 then + declare + function Check_Bound_Subexpression + (Exp : Node_Id) return Traverse_Result; + -- A bound expression for a subaggregate of an + -- array aggregate is not permitted to reference + -- a loop iteration variable defined in an earlier + -- dimension of the same enclosing aggregate, as + -- in (for X in 1 .. 3 => (1 .. X + 2 => ...)) . + -- Always returns OK. + + -------------------------------- + -- Check_Bound_Subexpression -- + -------------------------------- + + function Check_Bound_Subexpression + (Exp : Node_Id) return Traverse_Result + is + Scope_Parent : Node_Id; + begin + if Nkind (Exp) /= N_Identifier + or else not Present (Entity (Exp)) + or else not Present (Scope (Entity (Exp))) + or else Ekind (Scope (Entity (Exp))) /= E_Loop + then + return OK; + end if; + + Scope_Parent := Parent (Scope (Entity (Exp))); + + if Nkind (Scope_Parent) = N_Aggregate + + -- We want to know whether the aggregate + -- where this loop var is defined is + -- "the same" aggregate as N, where "the + -- same" means looking through subaggregates. + -- To do this, we compare Etypes of the two. + -- + -- ??? There may be very obscure cases + -- involving allocators where this is too + -- strict and will generate a spurious error. + + and then Etype (Scope_Parent) = Etype (N) + then + Error_Msg_N ("bound expression for a " + & "subaggregate of an array aggregate must " + & "not refer to an index parameter of an " + & "earlier dimension", Exp); + end if; + + return OK; + end Check_Bound_Subexpression; + + procedure Check_Bound_Expression is new + Traverse_Proc (Check_Bound_Subexpression); + begin + Check_Bound_Expression (Low); + Check_Bound_Expression (High); + end; + end if; end if; if not (All_Composite_Constraints_Static (Low) @@ -3706,6 +3782,10 @@ package body Sem_Aggr is Analyze_Dimension_Array_Aggregate (N, Component_Typ); + if Serious_Errors_Detected /= Saved_SED then + return Failure; + end if; + return Success; end Resolve_Array_Aggregate; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5cea155..0770baf 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -29,6 +29,7 @@ with Atree; use Atree; with Checks; use Checks; with Contracts; use Contracts; with Debug; use Debug; +with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -4529,6 +4530,9 @@ package body Sem_Ch13 is if (No (Expr) or else Entity (Expr) = Standard_True) and then not Core_Extensions_Allowed then + Error_Msg_GNAT_Extension + ("'First_'Controlling_'Parameter", Sloc (Aspect), + Is_Core_Extension => True); goto Continue; end if; @@ -4544,19 +4548,24 @@ package body Sem_Ch13 is goto Continue; end if; - -- If the aspect is specified for a derived type, the - -- specified value shall be confirming. - if Present (Expr) - and then Is_Derived_Type (E) - and then - Has_First_Controlling_Parameter_Aspect (Etype (E)) and then Entity (Expr) = Standard_False then - Error_Msg_Name_1 := Nam; - Error_Msg_N - ("specification of inherited aspect% can only " - & "confirm parent value", Id); + -- If the aspect is specified for a derived type, + -- the specified value shall be confirming. + + if Is_Derived_Type (E) + and then Has_First_Controlling_Parameter_Aspect + (Etype (E)) + then + Error_Msg_Name_1 := Nam; + Error_Msg_N + ("specification of inherited True value for " + & "aspect% can only confirm parent value", + Id); + end if; + + goto Continue; end if; -- Given that the aspect has been explicitly given, @@ -5757,13 +5766,18 @@ package body Sem_Ch13 is if not Check_Primitive_Function (Subp) then if Present (Ref_Node) then - Error_Msg_N ("improper function for default iterator!", - Ref_Node); - Error_Msg_Sloc := Sloc (Subp); - Error_Msg_NE - ("\\default iterator defined # " - & "must be a primitive function", - Ref_Node, Subp); + if Debug_Flag_Underscore_DD then + Record_Default_Iterator_Not_Primitive_Error + (Ref_Node, Subp); + else + Error_Msg_N ("improper function for default iterator!", + Ref_Node); + Error_Msg_Sloc := Sloc (Subp); + Error_Msg_NE + ("\\default iterator defined # " + & "must be a primitive function", + Ref_Node, Subp); + end if; end if; return False; @@ -15519,20 +15533,41 @@ package body Sem_Ch13 is -------------- procedure Too_Late is + S : Entity_Id; begin -- Other compilers seem more relaxed about rep items appearing too -- late. Since analysis tools typically don't care about rep items -- anyway, no reason to be too strict about this. if not Relaxed_RM_Semantics then - Error_Msg_N ("|representation item appears too late!", N); + if Debug_Flag_Underscore_DD then + + S := First_Subtype (T); + if Present (Freeze_Node (S)) then + Record_Representation_Too_Late_Error + (Rep => N, + Freeze => Freeze_Node (S), + Def => S); + else + Error_Msg_N ("|representation item appears too late!", N); + end if; + + else + Error_Msg_N ("|representation item appears too late!", N); + + S := First_Subtype (T); + if Present (Freeze_Node (S)) then + Error_Msg_NE + ("??no more representation items for }", + Freeze_Node (S), S); + end if; + end if; end if; end Too_Late; -- Local variables Parent_Type : Entity_Id; - S : Entity_Id; -- Start of processing for Rep_Item_Too_Late @@ -15566,14 +15601,6 @@ package body Sem_Ch13 is end if; Too_Late; - S := First_Subtype (T); - - if Present (Freeze_Node (S)) then - if not Relaxed_RM_Semantics then - Error_Msg_NE - ("??no more representation items for }", Freeze_Node (S), S); - end if; - end if; return True; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 9b77a81..9afaa89 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -27,6 +27,7 @@ with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Debug; use Debug; +with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -10861,40 +10862,86 @@ package body Sem_Ch4 is end loop; if No (Op_Id) then - Error_Msg_N ("invalid operand types for operator&", N); + if Debug_Flag_Underscore_DD then + if Nkind (N) /= N_Op_Concat then + if Nkind (N) in N_Op_Multiply | N_Op_Divide + and then Is_Fixed_Point_Type (Etype (L)) + and then Is_Integer_Type (Etype (R)) + then + Record_Invalid_Operand_Types_For_Operator_R_Int_Error + (Op => N, + L => L, + L_Type => Etype (L), + R => R, + R_Type => Etype (R)); + + elsif Nkind (N) = N_Op_Multiply + and then Is_Fixed_Point_Type (Etype (R)) + and then Is_Integer_Type (Etype (L)) + then + Record_Invalid_Operand_Types_For_Operator_L_Int_Error + (Op => N, + L => L, + L_Type => Etype (L), + R => R, + R_Type => Etype (R)); + else + Record_Invalid_Operand_Types_For_Operator_Error + (Op => N, + L => L, + L_Type => Etype (L), + R => R, + R_Type => Etype (R)); + end if; + elsif Is_Access_Type (Etype (L)) then + Record_Invalid_Operand_Types_For_Operator_L_Acc_Error + (Op => N, + L => L); + + elsif Is_Access_Type (Etype (R)) then + Record_Invalid_Operand_Types_For_Operator_R_Acc_Error + (Op => N, + R => R); + else + Record_Invalid_Operand_Types_For_Operator_General_Error + (N); + end if; + else + Error_Msg_N ("invalid operand types for operator&", N); - if Nkind (N) /= N_Op_Concat then - Error_Msg_NE ("\left operand has}!", N, Etype (L)); - Error_Msg_NE ("\right operand has}!", N, Etype (R)); + if Nkind (N) /= N_Op_Concat then + Error_Msg_NE ("\left operand has}!", N, Etype (L)); + Error_Msg_NE ("\right operand has}!", N, Etype (R)); - -- For multiplication and division operators with - -- a fixed-point operand and an integer operand, - -- indicate that the integer operand should be of - -- type Integer. + -- For multiplication and division operators with + -- a fixed-point operand and an integer operand, + -- indicate that the integer operand should be of + -- type Integer. - if Nkind (N) in N_Op_Multiply | N_Op_Divide - and then Is_Fixed_Point_Type (Etype (L)) - and then Is_Integer_Type (Etype (R)) - then - Error_Msg_N ("\convert right operand to `Integer`", N); + if Nkind (N) in N_Op_Multiply | N_Op_Divide + and then Is_Fixed_Point_Type (Etype (L)) + and then Is_Integer_Type (Etype (R)) + then + Error_Msg_N ("\convert right operand to `Integer`", N); - elsif Nkind (N) = N_Op_Multiply - and then Is_Fixed_Point_Type (Etype (R)) - and then Is_Integer_Type (Etype (L)) - then - Error_Msg_N ("\convert left operand to `Integer`", N); - end if; + elsif Nkind (N) = N_Op_Multiply + and then Is_Fixed_Point_Type (Etype (R)) + and then Is_Integer_Type (Etype (L)) + then + Error_Msg_N ("\convert left operand to `Integer`", N); + end if; - -- For concatenation operators it is more difficult to - -- determine which is the wrong operand. It is worth - -- flagging explicitly an access type, for those who - -- might think that a dereference happens here. + -- For concatenation operators it is more difficult to + -- determine which is the wrong operand. It is worth + -- flagging explicitly an access type, for those who + -- might think that a dereference happens here. - elsif Is_Access_Type (Etype (L)) then - Error_Msg_N ("\left operand is access type", N); + elsif Is_Access_Type (Etype (L)) then + Error_Msg_N ("\left operand is access type", N); - elsif Is_Access_Type (Etype (R)) then - Error_Msg_N ("\right operand is access type", N); + elsif Is_Access_Type (Etype (R)) then + Error_Msg_N ("\right operand is access type", N); + end if; end if; end if; end if; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index d52264a..b12db35 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -28,6 +28,8 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Contracts; use Contracts; +with Debug; use Debug; +with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -68,7 +70,6 @@ with Style; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; - package body Sem_Ch9 is ----------------------- @@ -2222,10 +2223,18 @@ package body Sem_Ch9 is -- Pragma case else - Error_Msg_Name_1 := Pragma_Name (Prio_Item); - Error_Msg_NE - ("pragma% for & has no effect when Lock_Free given??", - Prio_Item, Id); + if Debug_Flag_Underscore_DD then + Record_Pragma_No_Effect_With_Lock_Free_Warning + (Pragma_Node => Prio_Item, + Pragma_Name => Pragma_Name (Prio_Item), + Lock_Free_Node => Id, + Lock_Free_Range => Parent (Id)); + else + Error_Msg_Name_1 := Pragma_Name (Prio_Item); + Error_Msg_NE + ("pragma% for & has no effect when Lock_Free given??", + Prio_Item, Id); + end if; end if; end if; end; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index aaf0a76..de3f35e 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -33,6 +33,7 @@ with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; with Eval_Fat; use Eval_Fat; +with Exp_Intr; use Exp_Intr; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Lib; use Lib; @@ -191,7 +192,7 @@ package body Sem_Eval is -- (it is an error to make the call if these conditions are not met). procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id); - -- Evaluate a call N to an intrinsic subprogram E. + -- Evaluate a call N to an intrinsic subprogram E function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id; -- Check whether an arithmetic operation with universal operands which is a @@ -2888,13 +2889,43 @@ package body Sem_Eval is end if; case Nam is - when Name_Shift_Left => + + -- Compilation date and time are the same for the entire compilation + -- unit, so we can replace them with static strings. + + when Name_Compilation_ISO_Date + | Name_Compilation_Date + | Name_Compilation_Time + => + Expand_Source_Info (N, Nam); + + -- Calls to other intrinsics from the GNAT.Source_Info package give + -- different results, depending on where they occur. In particular, + -- for generics their results depend on where those generics are + -- instantiated; same for default values of subprogram parameters. + -- Those calls will behave as nonstatic, and we postpone their + -- rewriting until expansion. + + when Name_Enclosing_Entity + | Name_File + | Name_Line + | Name_Source_Location + => + if Inside_A_Generic + or else In_Spec_Expression + then + null; + else + Expand_Source_Info (N, Nam); + end if; + + when Name_Shift_Left => Eval_Shift (N, E, N_Op_Shift_Left); when Name_Shift_Right => Eval_Shift (N, E, N_Op_Shift_Right); when Name_Shift_Right_Arithmetic => Eval_Shift (N, E, N_Op_Shift_Right_Arithmetic); - when others => + when others => null; end case; end Eval_Intrinsic_Call; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index b139bd4..2d31c71 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -17761,22 +17761,55 @@ package body Sem_Prag is ---------------------------------------- when Pragma_First_Controlling_Parameter => First_Ctrl_Param : declare - Arg : Node_Id; - E : Entity_Id := Empty; + Arg : Node_Id; + E : Entity_Id := Empty; + Expr : Node_Id := Empty; begin - if not Core_Extensions_Allowed then - return; - end if; - GNAT_Pragma; - Check_Arg_Count (1); + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); Arg := Get_Pragma_Arg (Arg1); + Check_Arg_Is_Identifier (Arg); - if Nkind (Arg) = N_Identifier then - Analyze (Arg); - E := Entity (Arg); + Analyze (Arg); + E := Entity (Arg); + + if Present (Arg2) then + Check_Arg_Is_OK_Static_Expression (Arg2, Standard_Boolean); + Expr := Get_Pragma_Arg (Arg2); + Analyze_And_Resolve (Expr, Standard_Boolean); + end if; + + if not Core_Extensions_Allowed then + if No (Expr) + or else + (Present (Expr) + and then Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_True) + then + Error_Msg_GNAT_Extension + ("'First_'Controlling_'Parameter", Sloc (N), + Is_Core_Extension => True); + end if; + + return; + + elsif Present (Expr) + and then Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_False + then + if Is_Derived_Type (E) + and then Has_First_Controlling_Parameter_Aspect (Etype (E)) + then + Error_Msg_Name_1 := Name_First_Controlling_Parameter; + Error_Msg_N + ("specification of inherited True value for aspect% can " + & "only confirm parent value", Pragma_Identifier (N)); + end if; + + return; end if; if No (E) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b23ca48..e7fd7d6 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -144,10 +144,10 @@ package body Sem_Res is -- for restriction No_Direct_Boolean_Operators. This procedure also handles -- the style check for Style_Check_Boolean_And_Or. - function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean; - -- N is either an indexed component or a selected component. This function - -- returns true if the prefix denotes an atomic object that has an address - -- clause (the case in which we may want to issue a warning). + function Is_Atomic_Non_VFA_Ref_With_Address (N : Node_Id) return Boolean; + -- N is either an indexed component or a selected component. Return true + -- if the prefix denotes an Atomic but not Volatile_Full_Access object that + -- has an address clause (the case in which we may want to give a warning). function Is_Definite_Access_Type (E : N_Entity_Id) return Boolean; -- Determine whether E is an access type declared by an access declaration, @@ -1486,28 +1486,42 @@ package body Sem_Res is end if; end Check_Parameterless_Call; - -------------------------------- - -- Is_Atomic_Ref_With_Address -- - -------------------------------- + ---------------------------------------- + -- Is_Atomic_Non_VFA_Ref_With_Address -- + ---------------------------------------- - function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean is + function Is_Atomic_Non_VFA_Ref_With_Address (N : Node_Id) return Boolean is Pref : constant Node_Id := Prefix (N); - begin - if not Is_Entity_Name (Pref) then - return False; + function Is_Atomic_Non_VFA (E : Entity_Id) return Boolean; + -- Return true if E is Atomic but not Volatile_Full_Access - else + ----------------------- + -- Is_Atomic_Non_VFA -- + ----------------------- + + function Is_Atomic_Non_VFA (E : Entity_Id) return Boolean is + begin + return Is_Atomic (E) and then not Is_Volatile_Full_Access (E); + end Is_Atomic_Non_VFA; + + begin + if Is_Entity_Name (Pref) then declare Pent : constant Entity_Id := Entity (Pref); Ptyp : constant Entity_Id := Etype (Pent); + begin return not Is_Access_Type (Ptyp) - and then (Is_Atomic (Ptyp) or else Is_Atomic (Pent)) + and then (Is_Atomic_Non_VFA (Ptyp) + or else Is_Atomic_Non_VFA (Pent)) and then Present (Address_Clause (Pent)); end; + + else + return False; end if; - end Is_Atomic_Ref_With_Address; + end Is_Atomic_Non_VFA_Ref_With_Address; ----------------------------- -- Is_Definite_Access_Type -- @@ -9658,7 +9672,7 @@ package body Sem_Res is -- object, or partial word accesses, both of which may be unexpected. if Nkind (N) = N_Indexed_Component - and then Is_Atomic_Ref_With_Address (N) + and then Is_Atomic_Non_VFA_Ref_With_Address (N) and then not (Has_Atomic_Components (Array_Type) or else (Is_Entity_Name (Pref) and then Has_Atomic_Components @@ -11434,7 +11448,7 @@ package body Sem_Res is -- the atomic object, or partial word accesses, both of which may be -- unexpected. - if Is_Atomic_Ref_With_Address (N) + if Is_Atomic_Non_VFA_Ref_With_Address (N) and then not Is_Atomic (Entity (S)) and then not Is_Atomic (Etype (Entity (S))) and then Ada_Version < Ada_2022 diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index 13ab707..da940d1 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -564,9 +564,10 @@ is_return_from(void *symbol_addr, void *ret_addr) #error Unhandled QNX architecture. #endif -/*------------------- aarch64-linux or aarch64-rtems -----------------*/ +/*------------------- aarch64 FreeBSD, Linux, RTEMS -----------------*/ -#elif (defined (__aarch64__) && (defined (__linux__) || defined (__rtems__))) +#elif (defined (__aarch64__) && (defined (__FreeBSD__) || \ + defined (__linux__) || defined (__rtems__))) #define USE_GCC_UNWINDER #define PC_ADJUST -4 diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 5b77437..38a82be 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -538,6 +538,8 @@ begin Write_Line (" L* turn off warnings for elaboration problems"); Write_Line (" .l turn on info messages for inherited aspects"); Write_Line (" .L* turn off info messages for inherited aspects"); + Write_Line (" _l turn on warnings for implicitly limited types"); + Write_Line (" _L* turn off warnings for implicitly limited types"); Write_Line (" m+ turn on warnings for variable assigned " & "but not read"); Write_Line (" M* turn off warnings for variable assigned " & |