diff options
Diffstat (limited to 'gcc/ada')
174 files changed, 14075 insertions, 4087 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 04552dd..4b8658a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,930 @@ +2024-10-11 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/116498 + PR ada/117087 + * gcc-interface/decl.cc (validate_size): Fix thinko. + +2024-10-09 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/117038 + * fe.h (struct c_array): Add 'const' to declaration of pointer. + (C_Source_Buffer): Use consistent formatting. + * par-ch3.adb (P_Component_Items): Properly set Aliased_Present on + access definition. + * sinput.ads: Remove clause for Interfaces.C. + (C_Array): Change type of Length to Integer and make both components + aliased. Remove Convention aspect. + (C_Source_Buffer): Remove all aspects. + * sinput.adb (C_Source_Buffer): Adjust to above change. + +2024-10-09 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl: Remove HP-UX 10 section. + * libgnarl/s-osinte__hpux-dce.ads: Delete. + * libgnarl/s-osinte__hpux-dce.adb: Likewise. + * libgnarl/s-taprop__hpux-dce.adb: Likewise. + * libgnarl/s-taspri__hpux-dce.ads: Likewise. + * libgnat/s-oslock__hpux-dce.ads: Likewise. + +2024-10-08 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/116498 + * gcc-interface/decl.cc (validate_size): Use the size of the default + pointer mode as the minimum size for access types and fat pointers. + +2024-10-08 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (Raise_Error_to_gnu) <CE_Invalid_Data>: + Do not the generate range information if the value is a call to a + Rep_To_Pos function. + +2024-10-08 Olivier Hainque <hainque@adacore.com> + + * sigtramp-armdroid.c: Refactor into ... + * sigtramp-android.c, sigtramp-android-asm.h: New files. + * Makefile.rtl (arm/aarch64-android section): Add + sigtramp-android.o to EXTRA_LIBGNAT_OBJS unconditionally. Add + sigtramp.h and sigtramp-android-asm.h to EXTRA_LIBGNAT_SRCS. + * init.c (android section, __gnat_error_handler): Defer to + __gnat_sigramp unconditionally again. + * sigtramp.h: Adjust comments to allow neutral signal handling + relays, merely forwarding to the underlying handler without any + intermediate CFI magic. + +2024-10-08 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/115507 + * exp_imgv.adb (Expand_Valid_Value_Attribute): Add actual parameter + for Is_Wide formal in the call to Valid_Value_Enumeration_NN. + (Expand_Value_Attribute): Likewise. + * libgnat/s-vaen16.ads (Value_Enumeration_16): Add Is_Wide formal. + (Valid_Value_Enumeration_16): Likewise. + * libgnat/s-vaen32.ads (Value_Enumeration_32): Likewise. + (Valid_Value_Enumeration_32): Likewise. + * libgnat/s-vaenu8.ads (Value_Enumeration_8): Likewise. + (Valid_Value_Enumeration_8): Likewise. + * libgnat/s-valboo.adb (Value_Boolean): Pass True for To_Upper_Case + formal parameter in call to Normalize_String. + * libgnat/s-valcha.adb (Value_Character): Likewise. + * libgnat/s-valuen.ads (Value_Enumeration): Add Is_Wide formal. + (Valid_Value_Enumeration): Likewise. + * libgnat/s-valuen.adb (Value_Enumeration_Pos): Likewise and pass + its negation for To_Upper_Case formal in call to Normalize_String. + (Valid_Value_Enumeration): Add Is_Wide formal and forward it in + call to Value_Enumeration_Pos. + (Value_Enumeration): Likewise. + * libgnat/s-valuti.ads (Normalize_String): Add To_Upper_Case formal + parameter and adjust post-condition accordingly. + * libgnat/s-valuti.adb (Normalize_String): Add To_Upper_Case formal + parameter and adjust implementation accordingly. + * libgnat/s-valwch.adb (Value_Wide_Wide_Character): Pass False for + To_Upper_Case formal parameter in call to Normalize_String. + +2024-10-08 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/114636 + * sem_ch12.adb (Check_Formal_Package_Instance): For a defaulted + formal discrete type, skip the generated implicit base type. + +2024-10-08 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/115535 + * exp_put_image.adb (Build_Elementary_Put_Image_Call): Use the size + of the underlying type to find the support type. + +2024-10-08 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/114640 + * exp_util.adb (Find_Hook_Context): For a node present within a + conditional expression, do not return an N_Elsif_Part node. + +2024-10-08 Viljar Indus <indus@adacore.com> + + * diagnostics-constructors.adb + (Make_Mixed_Container_Aggregate_Error): New function for the error + message + (Record_Mixed_Container_Aggregate_Error): New function for the + error message. + * diagnostics-constructors.ads: Likewise. + * diagnostics-repository.ads: register new diagnostics id + * diagnostics.ads: add new diagnostics id + * errout.adb (First_And_Last_Node): Detect the span for component + associations. + * sem_aggr.adb (Resolve_Container_Aggregate): reject container + aggregates that have both named and positional elements. + +2024-10-08 Ronan Desplanques <desplanques@adacore.com> + + * snames.ads-tmpl: Add new pragma definition. + * par-prag.adb (Prag): Handle new pragma. + * sem_prag.adb (Analyze_Pragma): Implement new pragma. + +2024-10-08 Ronan Desplanques <desplanques@adacore.com> + + * snames.ads-tmpl: Tweak position of comment. + +2024-10-08 Tonu Naks <naks@adacore.com> + + * doc/gnat_rm/gnat_language_extensions.rst: replace + references to RFC's with appropriate text from the rfc + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2024-10-08 Ronan Desplanques <desplanques@adacore.com> + + * lib-writ.ads (Add_Preprocessing_Dependency): Update + documentation comment. + * sem_ch3.adb (Apply_External_Initialization): Add call to + Add_Preprocessing_Dependency. + +2024-10-08 Viljar Indus <indus@adacore.com> + + * exp_aggr.adb (Build_Siz_Exp): Support deriving the size of the + container aggregate with multi-dimensional arrays. Make the + function return an node of an expression instead of an integer. + Additionally calculate the size expression for + Component_Associations. + (To_Int) make this method available for more functions. + (Aggregate_Size) Relocate the calculation of + Componenet_Associations to Build_Siz_Exp. + +2024-10-08 Eric Botcazou <ebotcazou@adacore.com> + + * exp_tss.ads (Is_Rep_To_Pos): New function declaration. + * exp_tss.adb (Is_Rep_To_Pos): New function body. + * fe.h (Is_Rep_To_Pos): New macro and extern declaration. + +2024-10-08 Eric Botcazou <ebotcazou@adacore.com> + + * exp_imgv.adb (Rewrite_Object_Image): When the prefix is a type + conversion to Universal_Integer, use its expression directly. When + the prefix is an integer literal with Universal_Integer type, try + to compute a narrower type. + +2024-10-08 Raphaël AMIARD <amiard@adacore.com> + + * par-ch11.adb (P_Sequence_Of_Statements): Remove Handled + parameter. Always wrap the statements in a block when there are + declarations in it. + * par-ch5.adb: Adapt call to P_Sequence_Of_Statements Update + outdated comment, remove useless `Style_Checks` pragma. + (P_Sequence_Of_Statements): Don't emit an error in core extensions + mode. Emit an error when a non valid declaration is parsed in + sequence of statements. + * par.adb: Adapt P_Sequence_Of_Statements' signature + * doc/gnat_rm/gnat_language_extensions.rst: Adapt documentation + now. + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2024-10-08 Ronan Desplanques <desplanques@adacore.com> + + * generate_minimal_reproducer.adb (Generate_Minimal_Reproducer): + Fix behavior on child subprograms without specs. + +2024-10-08 Steve Baird <baird@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Don't freeze here + if Has_Delayed_Freeze returns True. + * sem_type.adb (Valid_Equality_Arg): Treat an incomplete type like + a limited type because neither has an implicitly-defined equality + primitive. + (Covers): If either argument is an incomplete type + whose full view is available, then look through to the full view. + * sem_res.adb (Resolve_Actuals): If the actual parameter type is + complete and the formal parameter type is not, then update the + formal parameter type to use the complete view. + +2024-10-08 squirek <squirek@adacore.com> + + * sem_ch3.adb (Derived_Type_Declaration): Modify generation of + compile time check. + +2024-10-08 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-trasym__dwarf.adb (LDAD_Header): New String constant. + (Symbolic_Traceback): Print the load address of the executable at + the beginning if it is not null. + +2024-10-08 Steve Baird <baird@adacore.com> + + * sem_ch6.adb (Check_Discriminant_Conformance): In testing whether + a default expression is permitted for an access discriminant, we + need to know whether the discriminated type is immutably limited. + Handle another part of this test that cannot easily be handled in + Sem_Aux.Is_Immutably_Limited. This involves declaring a new local + function, Is_Derived_From_Immutably_Limited_Type. + +2024-10-08 Steve Baird <baird@adacore.com> + + * sem_attr.adb (Resolve_Attribute): When setting the Etype of a + universal-integer-valued attribute reference to the subtype + determined by its context, use the basetype of that subtype + instead of the subtype itself if there is a possibility that the + attribute value will not satisfy the constraints of that subtype. + Otherwise the compiler is, in effect, assuming something that + might not be true. Except use the subtype in the case of a + not-from-source 'Pos attribute reference in order to avoid + breaking things. + +2024-10-08 Ronan Desplanques <desplanques@adacore.com> + + * comperr.adb (Compiler_Abort): Add call to + Generate_Minimal_Reproducer and replace call to Namet.Unlock with + call to Unlock_If_Locked. + * debug.adb: Document new purpose of -gnatd_m and -gnatd_M. + * fname-uf.adb (Instantiate_SFN_Pattern): New procedure. + (Get_Default_File_Name): New function. + (Get_File_Name): Replace inline code with call to + Instantiate_SFN_Pattern. + * fname-uf.ads (Get_Default_File_Name): New function. + * generate_minimal_reproducer.adb (Generate_Minimal_Reproducer): + New procedure. + * namet.adb (Unlock_If_Locked): New function. + * namet.ads (Unlock_If_Locked): Likewise. + * par-prag.adb (Prag): Add special behavior with -gnatd_M. + * set_targ.adb: Minor fixes to comments. + * gcc-interface/Make-lang.in: Update list of object files. + +2024-10-08 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.ads (Is_Two_Pass_Aggregate): New function declaration. + * exp_aggr.adb (Is_Two_Pass_Aggregate): New function body. + (Expand_Array_Aggregate): Call Is_Two_Pass_Aggregate to detect the + aggregates that need the 2-pass expansion. + * exp_ch3.adb (Expand_Freeze_Array_Type): In the anonymous array + case, build the initialization procedure if the initial value in + the object declaration is a 2-pass aggregate. + +2024-10-08 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_prag.adb (Process_Compile_Time_Warning_Or_Error): Fix + indentation. + +2024-10-08 Ronan Desplanques <desplanques@adacore.com> + + * aspects.ads: Add entities for External_Initialization. + * checks.adb (Selected_Length_Checks): Add support for + N_External_Initializer nodes. + * doc/gnat_rm/gnat_language_extensions.rst: Add section for the added + extension. + * exp_util.adb (Insert_Actions): Add support for N_External_Initializer + nodes. + * fe.h (C_Source_Buffer): New function. + * gen_il-fields.ads: Add new field. + * gen_il-gen-gen_nodes.adb: Add N_External_Initializer node kind. + * gen_il-gen.adb: Add new field type. + * gen_il-types.ads: Add new node kind and new field type. + * pprint.adb (Expr_Name): Handle new node kind. + * sem.adb (Analyze): Add support for N_External_Initializer nodes. + * sem_ch13.adb (Analyze_Aspect_Specifications, Check_Aspect_At_Freeze_Point): + Add support for External_Initialization aspect. + * sem_ch3.adb (Apply_External_Initialization): New subprogram. + (Analyze_Object_Declaration): Add support for External_Initialization aspect. + * sem_res.adb (Resolve_External_Initializer): New procedure. + (Resolve): Add support for N_External_Initializer nodes. + (Set_String_Literal_Subtype): Extend to handle N_External_Initializer nodes. + * sinfo-utils.adb (Is_In_Union_Id): Adapt to new field addition. + * sinfo.ads: Add documentation for new node kind and new field. + * sinput.adb, sinput.ads (C_Source_Buffer): Add new C interface function. + * snames.ads-tmpl: Add new aspect identifier. + * sprint.adb (Sprint_Node_Actual): Add nop handling of N_External_Initializer + nodes. + * types.ads: Modify type to allow for new C interface. + * gcc-interface/trans.cc (gnat_to_gnu): Handle new GNAT node type. + * gcc-interface/Make-lang.in: Update list of stage1 run-time library units. + * gnat-style.texi: Regenerate. + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2024-10-08 Olivier Hainque <hainque@adacore.com> + + * Makefile.rtl (arm/aarch64-android): Associate a-nallfl.ads with + libgnat/a-nallfl__wraplf.ads. + +2024-10-08 Olivier Hainque <hainque@adacore.com> + + * libgnarl/s-linux__android-arm.ads: Define SIGSYS. + * libgnarl/s-linux__android-aarch64.ads: Define SIGSYS. + * libgnarl/s-osinte__android.ads: Expose SIGSYS value. + +2024-10-08 Olivier Hainque <hainque@adacore.com> + + * libgnarl/s-linux__android-arm.ads: New file, renaming of ... + * libgnarl/s-linux__android.ads: ... this file. + * libgnarl/s-linux__android-aarch64.ads: New file. Based on the + -arm variant, with sa_ field positions adjusted. + * Makefile.rtl (arm/aarch64-android pairs): Adjust accordingly. + * libgnarl/s-osinte__android.ads: Rather than making assumptions + on the actual type of the C sigset_t, use + Os_Constants.SIZEOF_sigset_t to define an Ada sigset_t type of the + proper size. Use C.int instead of unsigned_long for sa_flags. + +2024-10-08 Olivier Hainque <hainque@adacore.com> + + * init.c (__gnat_error_handler): Map signals straight to Ada + exceptions, without a local CFI trampoline. + (__gnat_adjust_context_for_raise): Guard arm specific code on __arm__ + compilation. Do nothing otherwise, relying on libgcc's signal + frame recognition for PC/RA adjustments. + +2024-10-08 Olivier Hainque <hainque@adacore.com> + + * Makefile.rtl: Extend arm-android section to aarch64, in a similar + fashion as other arm/arch64 configurations. Introduce pair + selection guards to prevent match of aarch64-linux-android on the + regular aarch64-linux% cross as well. + +2024-10-08 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_prag.adb (Process_Compile_Time_Warning_Or_Error): Turn + Compile_Time pragmas into null nodes + +2024-10-05 Eric Botcazou <ebotcazou@adacore.com> + + PR middle-end/116933 + * gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Out_Parameter>: Add + the "uninitialized" attribute on Out parameters. + * gcc-interface/utils.cc (gnat_internal_attributes): Add entry for + the "uninitialized" attribute. + (handle_uninitialized_attribute): New function. + +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 + * gcc-interface/utils2.cc (fast_modulo_reduction): Require mode. + (nonbinary_modular_operation): Ditto. + +2024-08-23 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/misc.cc (gnat_get_array_descr_info): Test the + BIT_PACKED_ARRAY_TYPE_P flag only once on the final debug type. In + the case of records containing a template, replay the entire + processing for the array type contained therein. + +2024-08-23 Javier Miranda <miranda@adacore.com> + + * scng.adb (Scan): Call Error_Msg_GNAT_Extension() to report an + error, when the sources are compiled without Core_Extensions_ + Allowed, and the scanner detects the beginning of an interpolated + string. + +2024-08-23 Sebastian Poeplau <poeplau@adacore.com> + + * libgnat/s-dwalin.adb (Symbolic_Address): Ignore symbol size in + address-to-symbol translation for PECOFF files. + +2024-08-23 Javier Miranda <miranda@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference: [Put_Image]): Add + support for custom string types. + * exp_ch2.adb (Expand_N_Interpolated_String_Literal): Add a type + conversion to the result object declaration of custom string + types. + * exp_put_image.adb (Build_String_Put_Image_Call): Handle custom + string types. + +2024-08-23 Steve Baird <baird@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Implicit_Dereference): Generate + error if an aspect specification specifies the + Implicit_Dereference aspect of a non-first subtype. + +2024-08-23 Steve Baird <baird@adacore.com> + + * checks.adb (Is_Signed_Integer_Arithmetic_Op): Return True in the + case of relational operator whose operands are of a signed integer + type. + +2024-08-23 Viljar Indus <indus@adacore.com> + + * libgnat/a-coinho__shared.ads: add limited keyword. + * libgnat/g-awk.adb: add limited keyword. + * libgnat/g-comlin.ads: add limited keyword. + * libgnat/s-excmac__arm.ads: add limited keyword. + * libgnat/s-excmac__gcc.ads: add limited keyword. + * libgnat/s-soflin.ads: add limited keyword. + +2024-08-23 Viljar Indus <indus@adacore.com> + + * sem_ch3.adb: Add method Check_Inherited_Limted_Record for + emitting the warning for an inherited limited type. + * warnsw.adb: Add processing for the -gnatw_l switch that + triggeres the inheritly limited type warning. + * warnsw.ads: same as above. + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Add + entry for -gnatw_l switch. + * gnat_ugn.texi: Regenerate. + +2024-08-23 Javier Miranda <miranda@adacore.com> + + * sem_ch6.adb (Check_Private_Overriding): Improve code detecting + error on private function with controlling result. Fixes the + regression of ACATS bde0003. + +2024-08-23 Piotr Trojanek <trojanek@adacore.com> + + * checks.ads, cstand.adb, exp_aggr.adb, exp_ch4.adb, exp_ch5.adb, + exp_dbug.adb, exp_util.adb, gnatlink.adb, lib-util.adb, + libgnat/a-except.adb, libgnat/a-exexpr.adb, libgnat/a-ngcoar.adb, + libgnat/s-rannum.adb, libgnat/s-trasym__dwarf.adb, osint.adb, + rtsfind.adb, sem_case.adb, sem_ch12.adb, sem_ch13.adb, + sem_ch3.adb, sem_ch6.adb, sem_eval.adb, sem_prag.adb, + sem_util.adb: Fix style. + +2024-08-23 Piotr Trojanek <trojanek@adacore.com> + + * checks.adb (Ensure_Valid): Remove detection of boolean and + short-circuit operators. + (Expr_Known_Valid): Detect short-circuit operators; detection of + boolean operators was already done in this routine. + +2024-08-23 Piotr Trojanek <trojanek@adacore.com> + + * checks.adb (Ensure_Valid): Use Find_Actual. + +2024-08-23 Piotr Trojanek <trojanek@adacore.com> + + * checks.adb (Ensure_Valid): Use First_Actual/Next_Actual. + * exp_ch6.adb (Is_Direct_Deep_Call): Likewise. + * exp_util.adb (Type_Of_Formal): Likewise. + * sem_util.adb (Is_Container_Element): Likewise; cleanup + membership test by using a subtype. + +2024-08-23 Javier Miranda <miranda@adacore.com> + + * sem_ch13.adb (Analyze_One_Aspect): Temporarily remove reporting + an error when the new aspect is set to True and the extensions are + not enabled. + +2024-08-23 Javier Miranda <miranda@adacore.com> + + * exp_util.ads (Is_Expanded_Class_Wide_Interface_Object_Decl): New + subprogram. + * exp_util.adb (Is_Expanded_Class_Wide_Interface_Object_Decl): + ditto. + * sem_util.adb (Is_Aliased_View): Handle expanded class-wide type + object declaration. + * checks.adb (Is_Aliased_Unconstrained_Component): Protect the + frontend against calling Is_Aliased_View with Empty. Found working + on this issue. + +2024-08-23 Javier Miranda <miranda@adacore.com> + + * aspects.ads (Aspect_First_Controlling_Parameter): New aspect. + Defined as implementation defined aspect that has a static boolean + value and it is converted to pragma when the value is True. + * einfo.ads (Has_First_Controlling_Parameter): New attribute. + * exp_ch9.adb (Build_Corresponding_Record): Propagate the aspect + to the corresponding record type. + (Expand_N_Protected_Type_Declaration): Analyze the inherited + aspect to add the pragma. + (Expand_N_Task_Type_Declaration): ditto. + * freeze.adb (Warn_If_Implicitly_Inherited_Aspects): New + subprogram. + (Has_First_Ctrl_Param_Aspect): New subprogram. + (Freeze_Record_Type): Call Warn_If_Implicitly_Inherited_Aspects. + (Freeze_Subprogram): Check illegal subprograms of tagged types and + interface types that have this new aspect. + * gen_il-fields.ads (Has_First_Controlling_Parameter): New entity + field. + * gen_il-gen-gen_entities.adb (Has_First_Controlling_Parameter): + The new field is a semantic flag. + * gen_il-internals.adb (Image): Add + Has_First_Controlling_Parameter. + * par-prag.adb (Prag): No action for + Pragma_First_Controlling_Parameter since processing is handled + entirely in Sem_Prag. + * sem_ch12.adb (Validate_Private_Type_Instance): When the generic + formal has this new aspect, check that the actual type also has + this aspect. + * sem_ch13.adb (Analyze_One_Aspect): Check that the aspect is + applied to a tagged type or a concurrent type. + * sem_ch3.adb (Analyze_Full_Type_Declaration): Derived tagged + types inherit this new aspect, and also from their implemented + interface types. + (Process_Full_View): Propagate the aspect to the full view. + * sem_ch6.adb (Is_A_Primitive): New subprogram; used to factor + code and also clarify detection of primitives. + * sem_ch9.adb (Check_Interfaces): Propagate this new aspect to the + type implementing interface types. + * sem_disp.adb (Check_Controlling_Formals): Handle tagged type + that has the aspect and has subprograms overriding primitives of + tagged types that lack this aspect. + (Check_Dispatching_Operation): Warn on dispatching primitives + disallowed by this new aspect. + (Has_Predefined_Dispatching_Operation_Name): New subprogram. + (Find_Dispatching_Type): Handle dispatching functions of tagged + types that have the new aspect. + (Find_Primitive_Covering_Interface): For primitives of tagged + types that have the aspect and override a primitive of a parent + type that does not have the aspect, we must temporarily unset + attribute First_Controlling_ Parameter to properly check + conformance. + * sem_prag.ads (Aspect_Specifying_Pragma): Add new pragma. + * sem_prag.adb (Pragma_First_Controlling_Parameter): Handle new + pragma. + * snames.ads-tmpl (Name_First_Controlling_Parameter): New name. + * warnsw.ads (Warn_On_Non_Dispatching_Primitives): New warning. + * warnsw.adb (Warn_On_Non_Dispatching_Primitives): New warning; + not set by default when GNAT_Mode warnings are enabled, nor when + all warnings are enabled (-gnatwa). + +2024-08-19 Arsen Arsenović <arsen@aarsen.me> + + PR ada/115917 + * gnatvsn.ads: Add note about the duplication of this value in + version.c. + * version.c (VER_LEN_MAX): Define to the same value as + Gnatvsn.Ver_Len_Max. + (gnat_version_string): Use VER_LEN_MAX as bound. + 2024-08-08 Steve Baird <baird@adacore.com> * sem_ch6.adb (Check_Discriminant_Conformance): Perform check for diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 1512c01..a36f601 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1079,9 +1079,21 @@ GCC_SPEC_FILES= # $(strip STRING) removes leading and trailing spaces from STRING. # If what's left is null then it's a match. +# Setup to make sure at most one match gets selected, useful for android +# targets which are canonically configured with a linux-android target_os, +# which would match filtering patterns such as linux% intended to match +# only regular linux or linux64 variants. + +# The current set of selected pairs. A new match remains allowed +# as long as this isn't assigned a new value. +SELECTED_PAIRS=PAIRS_NONE + # PowerPC VxWorks6 and VxWorks7 +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7%, $(target_cpu) $(target_vendor) $(target_os))),) + SELECTED_PAIRS=powerpc-vxworks + ifeq ($(strip $(filter-out powerpc64, $(target_cpu))),) ARCH_STR=ppc64 else @@ -1189,10 +1201,14 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7%, $(target_cpu) $(targe GCC_SPEC_FILES+=vxworks-smp-$(ARCH_STR)-link.spec endif endif +endif # x86/x86_64 VxWorks7 +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks7%, $(target_cpu) $(target_vendor) $(target_os))),) + SELECTED_PAIRS=x86-vxworks7 + LIBGNAT_TARGET_PAIRS= \ a-intnam.ads<libgnarl/a-intnam__vxworks.ads \ i-vxwork.ads<libgnat/i-vxwork__x86.ads \ @@ -1298,10 +1314,14 @@ ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks7%, $(target_cpu) $(target_vend GCC_SPEC_FILES+=vxworks7-$(X86CPU)-rtp-base-link.spec endif +endif # ARM and Aarch64 VxWorks7 +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out aarch64 arm wrs vxworks7%, $(target_cpu) $(target_vendor) $(target_os))),) + SELECTED_PAIRS=arm-vxworks7 + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__vxworks.ads \ a-naliop.ads<libgnat/a-naliop__nolibm.ads \ @@ -1384,14 +1404,16 @@ ifeq ($(strip $(filter-out aarch64 arm wrs vxworks7%, $(target_cpu) $(target_ven GCC_SPEC_FILES+=vxworks7-rtp-base-link.spec endif +endif + +# ARM and AARCH64 Android +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) +ifeq ($(strip $(filter-out arm% aarch64 linux-android%,$(target_cpu) $(target_os))),) -# ARM android -ifeq ($(strip $(filter-out arm% linux-androideabi,$(target_cpu) $(target_os))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ s-intman.adb<libgnarl/s-intman__android.adb \ - s-linux.ads<libgnarl/s-linux__android.ads \ s-osinte.adb<libgnarl/s-osinte__android.adb \ s-osinte.ads<libgnarl/s-osinte__android.ads \ s-oslock.ads<libgnat/s-oslock__posix.ads \ @@ -1399,6 +1421,7 @@ ifeq ($(strip $(filter-out arm% linux-androideabi,$(target_cpu) $(target_os))),) s-taprop.adb<libgnarl/s-taprop__posix.adb \ s-taspri.ads<libgnarl/s-taspri__posix.ads \ s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ system.ads<libgnat/system-linux-arm.ads @@ -1406,16 +1429,42 @@ ifeq ($(strip $(filter-out arm% linux-androideabi,$(target_cpu) $(target_os))),) TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb EXTRA_GNATRTL_TASKING_OBJS=s-linux.o - EXTRA_LIBGNAT_OBJS+=sigtramp-armdroid.o - EXTRA_LIBGNAT_SRCS+=sigtramp.h - EH_MECHANISM=-arm + + # ARM and aarch64 rely on different unwinding mechanisms, and as + # a 64bit target, aarch64 can also incorporate support for 128bit + # arithmetic. + + ifeq ($(strip $(filter-out arm%, $(target_cpu))),) + SELECTED_PAIRS=arm-android + + EH_MECHANISM=-arm + LIBGNAT_TARGET_PAIRS += \ + s-linux.ads<libgnarl/s-linux__android-arm.ads + else + SELECTED_PAIRS=aarch64-android + + EH_MECHANISM=-gcc + LIBGNAT_TARGET_PAIRS += \ + s-linux.ads<libgnarl/s-linux__android-aarch64.ads + + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS = $(GNATRTL_128BIT_OBJS) + endif + + EXTRA_LIBGNAT_OBJS+=sigtramp-android.o + EXTRA_LIBGNAT_SRCS+=sigtramp.h sigtramp-android-asm.h THREADSLIB = GNATLIB_SHARED = gnatlib-shared-dual LIBRARY_VERSION := $(LIB_VERSION) endif +endif # ARM and AARCH64 QNX +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out arm aarch64 %qnx,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=arm-qnx + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__qnx.ads \ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ @@ -1460,9 +1509,14 @@ ifeq ($(strip $(filter-out arm aarch64 %qnx,$(target_cpu) $(target_os))),) THREADSLIB= LIBRARY_VERSION := $(LIB_VERSION) endif +endif # SPARC Solaris +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out sparc% sun solaris%,$(target_cpu) $(target_vendor) $(target_os))),) + + SELECTED_PAIRS=sparc-solaris + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__solaris.ads \ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ @@ -1505,9 +1559,14 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(target_cpu) $(target_vendor) $( GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # x86 and x86-64 Solaris +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=x86-solaris + LIBGNAT_TARGET_PAIRS_COMMON = \ a-intnam.ads<libgnarl/a-intnam__solaris.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -1559,9 +1618,14 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # x86 Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=x86-linux + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ a-synbar.adb<libgnarl/a-synbar__posix.adb \ @@ -1611,9 +1675,14 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),) GNATLIBCFLAGS_FOR_GCCSJLJ+=-fno-omit-frame-pointer -momit-leaf-frame-pointer endif +endif # x86 kfreebsd +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %86 kfreebsd%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=x86-kfreebsd + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__freebsd.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -1642,9 +1711,14 @@ ifeq ($(strip $(filter-out %86 kfreebsd%,$(target_cpu) $(target_os))),) LIBRARY_VERSION := $(LIB_VERSION) MISCLIB = -lutil endif +endif # i[3456]86-pc-gnu i.e. GNU Hurd +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %86 pc gnu,$(target_cpu) $(target_vendor) $(target_os))),) + + SELECTED_PAIRS=x86-gnuhurd + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__freebsd.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -1670,9 +1744,14 @@ ifeq ($(strip $(filter-out %86 pc gnu,$(target_cpu) $(target_vendor) $(target_os GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # x86-64 kfreebsd +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=x86_64-kfreebsd + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__freebsd.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -1699,9 +1778,14 @@ ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # aarch64 FreeBSD +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %aarch64 freebsd%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=aarch64-freebsd + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__freebsd.ads \ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ @@ -1731,9 +1815,14 @@ ifeq ($(strip $(filter-out %aarch64 freebsd%,$(target_cpu) $(target_os))),) LIBRARY_VERSION := $(LIB_VERSION) MISCLIB = -lutil endif +endif # x86 FreeBSD +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %86 freebsd%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=x86-freebsd + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__freebsd.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -1762,9 +1851,14 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(target_cpu) $(target_os))),) LIBRARY_VERSION := $(LIB_VERSION) MISCLIB = -lutil endif +endif # x86-64 FreeBSD +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %86_64 freebsd%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=x86_64-freebsd + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__freebsd.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -1795,9 +1889,14 @@ ifeq ($(strip $(filter-out %86_64 freebsd%,$(target_cpu) $(target_os))),) LIBRARY_VERSION := $(LIB_VERSION) MISCLIB = -lutil endif +endif # x86-64 DragonFly +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %86_64 dragonfly%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=x86_64-dragonfly + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__dragonfly.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -1826,9 +1925,14 @@ ifeq ($(strip $(filter-out %86_64 dragonfly%,$(target_cpu) $(target_os))),) LIBRARY_VERSION := $(LIB_VERSION) MISCLIB = -lutil endif +endif # S390 Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out s390% linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=s390-linux + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ @@ -1866,30 +1970,14 @@ ifeq ($(strip $(filter-out s390% linux%,$(target_cpu) $(target_os))),) GNATLIB_SHARED = gnatlib-shared-dual LIBRARY_VERSION := $(LIB_VERSION) endif - -# HP/PA HP-UX 10 -ifeq ($(strip $(filter-out hppa% hp hpux10%,$(target_cpu) $(target_vendor) $(target_os))),) - LIBGNAT_TARGET_PAIRS = \ - a-intnam.ads<libgnarl/a-intnam__hpux.ads \ - s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ - s-interr.adb<libgnarl/s-interr__sigaction.adb \ - s-intman.adb<libgnarl/s-intman__posix.adb \ - a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ - s-osinte.adb<libgnarl/s-osinte__hpux-dce.adb \ - s-osinte.ads<libgnarl/s-osinte__hpux-dce.ads \ - s-parame.ads<libgnat/s-parame__hpux.ads \ - s-oslock.ads<libgnat/s-oslock__posix.ads \ - s-osprim.adb<libgnat/s-osprim__posix.adb \ - s-taprop.adb<libgnarl/s-taprop__hpux-dce.adb \ - s-taspri.ads<libgnarl/s-taspri__hpux-dce.ads \ - s-tpopsp.adb<libgnarl/s-tpopsp__posix.adb \ - system.ads<libgnat/system-hpux.ads - - EH_MECHANISM=-gcc endif # HP/PA HP-UX 11 +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out hppa% hp hpux11%,$(target_cpu) $(target_vendor) $(target_os))),) + + SELECTED_PAIRS=hppa-hpux11 + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__hpux.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -1915,9 +2003,14 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(target_cpu) $(target_vendor) $(tar GNATLIB_SHARED = gnatlib-shared-dual LIBRARY_VERSION := $(LIB_VERSION) endif +endif # IBM AIX +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out ibm aix%,$(target_vendor) $(target_os))),) + + SELECTED_PAIRS=ibm-aix + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__aix.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -1952,9 +2045,14 @@ ifeq ($(strip $(filter-out ibm aix%,$(target_vendor) $(target_os))),) GMEM_LIB = gmemlib endif +endif # LynxOS 178 and LynxOS 178 Elf +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out lynxos178%,$(target_os))),) + + SELECTED_PAIRS=lynx178 + TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb LIBGNAT_TARGET_PAIRS = \ @@ -1989,9 +2087,14 @@ ifeq ($(strip $(filter-out lynxos178%,$(target_os))),) EH_MECHANISM=-gcc endif +endif # RTEMS +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out rtems%,$(target_os))),) + + SELECTED_PAIRS=rtems + LIBGNAT_TARGET_PAIRS = \ system.ads<libgnat/system-rtems.ads \ a-intnam.ads<libgnarl/a-intnam__rtems.ads \ @@ -2033,6 +2136,7 @@ ifeq ($(strip $(filter-out rtems%,$(target_os))),) $(ATOMICS_BUILTINS_TARGET_PAIRS) endif endif +endif # PikeOS ifeq ($(strip $(filter-out powerpc% %86 sysgo pikeos,$(target_cpu) $(target_vendor) $(target_os)))),) @@ -2044,7 +2148,11 @@ ifeq ($(strip $(filter-out elf eabi eabispe,$(target_os))),) TOOLS_TARGET_PAIRS=indepsw.adb<indepsw-gnu.adb endif +# gjgpp +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %djgpp,$(target_os))),) + + SELECTED_PAIRS=djgpp GNATRTL_SOCKETS_OBJS = LIBGNAT_TARGET_PAIRS = \ @@ -2060,9 +2168,14 @@ ifeq ($(strip $(filter-out %djgpp,$(target_os))),) EH_MECHANISM=-gcc endif +endif # Cygwin/Mingw32 +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),) + + SELECTED_PAIRS=cygming + # Cygwin provides a full Posix environment, and so we use the default # versions g-socthi rather than the Windows-specific MinGW version. # Ideally we would use all the default versions for Cygwin and none @@ -2147,9 +2260,14 @@ ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),) soext = .dll LIBRARY_VERSION := $(LIB_VERSION) endif +endif # LoongArch Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out loongarch% linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=loongarch-linux + LIBGNAT_TARGET_PAIRS = \ a-exetim.adb<libgnarl/a-exetim__posix.adb \ a-exetim.ads<libgnarl/a-exetim__default.ads \ @@ -2196,10 +2314,14 @@ ifeq ($(strip $(filter-out loongarch% linux%,$(target_cpu) $(target_os))),) GNATLIBCFLAGS += -mno-strict-align GNATLIBCFLAGS_FOR_C += -mno-strict-align endif - +endif # Mips Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out mips% linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=mips-linux + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ @@ -2238,9 +2360,14 @@ ifeq ($(strip $(filter-out mips% linux%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # PowerPC and e500v2 Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=powerpc-linux + LIBGNAT_TARGET_PAIRS = \ a-exetim.adb<libgnarl/a-exetim__posix.adb \ a-exetim.ads<libgnarl/a-exetim__default.ads \ @@ -2296,9 +2423,14 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # ARM linux, GNU eabi +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out arm% linux-gnueabi%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=arm-linux-gnueabi + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -2328,9 +2460,14 @@ ifeq ($(strip $(filter-out arm% linux-gnueabi%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # AArch64 Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=aarch64-linux + LIBGNAT_TARGET_PAIRS = \ a-exetim.adb<libgnarl/a-exetim__posix.adb \ a-exetim.ads<libgnarl/a-exetim__default.ads \ @@ -2371,9 +2508,14 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # SPARC Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out sparc% linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=sparc-linux + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ @@ -2416,9 +2558,14 @@ ifeq ($(strip $(filter-out sparc% linux%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # HP/PA Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out hppa% linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=hppa-linux + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -2444,9 +2591,14 @@ ifeq ($(strip $(filter-out hppa% linux%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # M68K Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out m68k% linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=m68k-linux + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -2472,9 +2624,14 @@ ifeq ($(strip $(filter-out m68k% linux%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # SH4 Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out sh4% linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=sh4-linux + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -2501,9 +2658,14 @@ ifeq ($(strip $(filter-out sh4% linux%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # IA64 Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %ia64 linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=ia64-linux + LIBGNAT_TARGET_PAIRS = \ a-exetim.adb<libgnarl/a-exetim__posix.adb \ a-exetim.ads<libgnarl/a-exetim__default.ads \ @@ -2544,9 +2706,14 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # IA64 HP-UX +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out ia64% hp hpux%,$(target_cpu) $(target_vendor) $(target_os))),) + + SELECTED_PAIRS=ia64-hpux + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__hpux.ads \ s-dorepr.adb<libgnat/s-dorepr__fma.adb \ @@ -2577,9 +2744,14 @@ ifeq ($(strip $(filter-out ia64% hp hpux%,$(target_cpu) $(target_vendor) $(targe SO_OPTS = -Wl,+h, LIBRARY_VERSION := $(LIB_VERSION) endif +endif # Alpha Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out alpha% linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=alpha-linux + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ @@ -2610,9 +2782,14 @@ ifeq ($(strip $(filter-out alpha% linux%,$(target_cpu) $(target_os))),) GNATLIB_SHARED=gnatlib-shared-dual LIBRARY_VERSION := $(LIB_VERSION) endif +endif # x86-64 Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=x86_64-linux + LIBGNAT_TARGET_PAIRS = \ a-exetim.adb<libgnarl/a-exetim__posix.adb \ a-exetim.ads<libgnarl/a-exetim__default.ads \ @@ -2656,8 +2833,14 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),) GNATLIBCFLAGS_FOR_GCCSJLJ+=-fno-omit-frame-pointer -momit-leaf-frame-pointer endif +endif +# x32-linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out %x32 linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=x32-linux + LIBGNAT_TARGET_PAIRS = \ a-exetim.adb<libgnarl/a-exetim__posix.adb \ a-exetim.ads<libgnarl/a-exetim__default.ads \ @@ -2698,9 +2881,14 @@ ifeq ($(strip $(filter-out %x32 linux%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # RISC-V Linux +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out riscv% linux%,$(target_cpu) $(target_os))),) + + SELECTED_PAIRS=riscv-linux + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ @@ -2740,9 +2928,14 @@ ifeq ($(strip $(filter-out riscv% linux%,$(target_cpu) $(target_os))),) GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif +endif # Darwin (Mac OS X) +ifeq ($(SELECTED_PAIRS),PAIRS_NONE) ifeq ($(strip $(filter-out darwin%,$(target_os))),) + + SELECTED_PAIRS=darwin + SO_OPTS = -shared-libgcc LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__darwin.ads \ @@ -2858,6 +3051,7 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),) soext = .dylib GCC_LINK_FLAGS=-static-libstdc++ endif +endif ifeq ($(EH_MECHANISM),-gcc) LIBGNAT_TARGET_PAIRS += \ 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/aspects.ads b/gcc/ada/aspects.ads index 9d0a9eb..2a5e0f2 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -96,6 +96,7 @@ package Aspects is Aspect_Dispatching_Domain, Aspect_Dynamic_Predicate, Aspect_Exceptional_Cases, -- GNAT + Aspect_External_Initialization, -- GNAT Aspect_External_Name, Aspect_External_Tag, Aspect_Finalizable, -- GNAT @@ -198,6 +199,7 @@ package Aspects is Aspect_Export, Aspect_Extensions_Visible, -- GNAT Aspect_Favor_Top_Level, -- GNAT + Aspect_First_Controlling_Parameter, -- GNAT Aspect_Full_Access_Only, Aspect_Ghost, -- GNAT Aspect_Import, @@ -292,8 +294,10 @@ package Aspects is Aspect_Effective_Writes => True, Aspect_Exceptional_Cases => True, Aspect_Extensions_Visible => True, + Aspect_External_Initialization => True, Aspect_Favor_Top_Level => True, Aspect_Finalizable => True, + Aspect_First_Controlling_Parameter => True, Aspect_Ghost => True, Aspect_Ghost_Predicate => True, Aspect_Global => True, @@ -435,6 +439,7 @@ package Aspects is Aspect_Dispatching_Domain => Expression, Aspect_Dynamic_Predicate => Expression, Aspect_Exceptional_Cases => Expression, + Aspect_External_Initialization => Expression, Aspect_External_Name => Expression, Aspect_External_Tag => Expression, Aspect_Finalizable => Expression, @@ -534,9 +539,11 @@ package Aspects is Aspect_Dynamic_Predicate => False, Aspect_Exceptional_Cases => False, Aspect_Exclusive_Functions => False, + Aspect_External_Initialization => False, Aspect_External_Name => False, Aspect_External_Tag => False, Aspect_Finalizable => False, + Aspect_First_Controlling_Parameter => False, Aspect_Ghost_Predicate => False, Aspect_Global => False, Aspect_GNAT_Annotate => False, @@ -708,10 +715,12 @@ package Aspects is Aspect_Exclusive_Functions => Name_Exclusive_Functions, Aspect_Export => Name_Export, Aspect_Extensions_Visible => Name_Extensions_Visible, + Aspect_External_Initialization => Name_External_Initialization, Aspect_External_Name => Name_External_Name, Aspect_External_Tag => Name_External_Tag, Aspect_Favor_Top_Level => Name_Favor_Top_Level, Aspect_Finalizable => Name_Finalizable, + Aspect_First_Controlling_Parameter => Name_First_Controlling_Parameter, Aspect_Full_Access_Only => Name_Full_Access_Only, Aspect_Ghost => Name_Ghost, Aspect_Ghost_Predicate => Name_Ghost_Predicate, @@ -1046,6 +1055,8 @@ package Aspects is Aspect_Exceptional_Cases => Never_Delay, Aspect_Export => Never_Delay, Aspect_Extensions_Visible => Never_Delay, + Aspect_External_Initialization => Never_Delay, + Aspect_First_Controlling_Parameter => Never_Delay, Aspect_Ghost => Never_Delay, Aspect_Global => Never_Delay, Aspect_GNAT_Annotate => Never_Delay, 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 38fe687..bc07876 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -330,10 +330,11 @@ package body Checks is function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean; -- Returns True if node N is for an arithmetic operation with signed - -- integer operands. This includes unary and binary operators, and also - -- if and case expression nodes where the dependent expressions are of - -- a signed integer type. These are the kinds of nodes for which special - -- handling applies in MINIMIZED or ELIMINATED overflow checking mode. + -- integer operands. This includes unary and binary operators (including + -- comparison operators), and also if and case expression nodes which + -- yield a value of a signed integer type. + -- These are the kinds of nodes for which special handling applies in + -- MINIMIZED or ELIMINATED overflow checking mode. function Range_Or_Validity_Checks_Suppressed (Expr : Node_Id) return Boolean; @@ -1549,7 +1550,7 @@ package body Checks is then if (Etype (N) = Typ or else (Do_Access and then Designated_Type (Typ) = S_Typ)) - and then not Is_Aliased_View (Lhs) + and then (No (Lhs) or else not Is_Aliased_View (Lhs)) then return; end if; @@ -6799,76 +6800,23 @@ package body Checks is if Is_Scalar_Type (Typ) then declare - P : Node_Id; - N : Node_Id; - E : Entity_Id; - F : Entity_Id; - A : Node_Id; - L : List_Id; + Formal : Entity_Id; + Call : Node_Id; begin - -- Find actual argument (which may be a parameter association) - -- and the parent of the actual argument (the call statement) + Find_Actual (Expr, Formal, Call); - N := Expr; - P := Parent (Expr); - - if Nkind (P) = N_Parameter_Association then - N := P; - P := Parent (N); - end if; - - -- If this is an indirect or dispatching call, get signature - -- from the subprogram type. - - if Nkind (P) in N_Entry_Call_Statement - | N_Function_Call - | N_Procedure_Call_Statement + if Present (Formal) + and then + (Ekind (Formal) = E_Out_Parameter + or else Mechanism (Formal) = By_Reference) then - E := Get_Called_Entity (P); - L := Parameter_Associations (P); - - -- Only need to worry if there are indeed actuals, and if - -- this could be a subprogram call, otherwise we cannot get - -- a match (either we are not an argument, or the mode of - -- the formal is not OUT). This test also filters out the - -- generic case. - - if Is_Non_Empty_List (L) and then Is_Subprogram (E) then - - -- This is the loop through parameters, looking for an - -- OUT parameter for which we are the argument. - - F := First_Formal (E); - A := First (L); - while Present (F) loop - if A = N - and then (Ekind (F) = E_Out_Parameter - or else Mechanism (F) = By_Reference) - then - return; - end if; - - Next_Formal (F); - Next (A); - end loop; - end if; + return; end if; end; end if; end if; - -- If this is a boolean expression, only its elementary operands need - -- checking: if they are valid, a boolean or short-circuit operation - -- with them will be valid as well. - - if Base_Type (Typ) = Standard_Boolean - and then - (Nkind (Expr) in N_Op or else Nkind (Expr) in N_Short_Circuit) - then - return; - end if; - -- If we fall through, a validity check is required Insert_Valid_Check (Expr, Related_Id, Is_Low_Bound, Is_High_Bound); @@ -6885,7 +6833,7 @@ package body Checks is ---------------------- function Expr_Known_Valid (Expr : Node_Id) return Boolean is - Typ : constant Entity_Id := Etype (Expr); + Typ : constant Entity_Id := Validated_View (Etype (Expr)); begin -- Non-scalar types are always considered valid, since they never give @@ -6989,9 +6937,10 @@ package body Checks is return True; -- The result of a membership test is always valid, since it is true or - -- false, there are no other possibilities. + -- false, there are no other possibilities; same for short-circuit + -- operators. - elsif Nkind (Expr) in N_Membership_Test then + elsif Nkind (Expr) in N_Membership_Test | N_Short_Circuit then return True; -- For all other cases, we do not know the expression is valid @@ -8389,6 +8338,9 @@ package body Checks is => return Is_Signed_Integer_Type (Etype (N)); + when N_Op_Compare => + return Is_Signed_Integer_Type (Etype (Left_Opnd (N))); + when N_Case_Expression | N_If_Expression => @@ -9760,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); @@ -9771,35 +9719,29 @@ package body Checks is Set_Do_Overflow_Check (N, False); case Nkind (N) is - when N_Op_Divide => + when N_Op_Divide + | N_Op_Mod + | N_Op_Rem + => 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 => - 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); @@ -9909,7 +9851,15 @@ package body Checks is if Ekind (Scope (E)) = E_Record_Type and then Has_Discriminants (Scope (E)) then - N := Build_Discriminal_Subtype_Of_Component (E); + -- If the expression is a selected component, in other words, + -- has a prefix, then build an actual subtype from the prefix. + -- Otherwise, build an actual subtype from the discriminal. + + if Nkind (Expr) = N_Selected_Component then + N := Build_Actual_Subtype_Of_Component (E, Expr); + else + N := Build_Discriminal_Subtype_Of_Component (E); + end if; if Present (N) then Insert_Action (Expr, N); @@ -10202,7 +10152,9 @@ package body Checks is -- T_Typ'Length = string-literal-length - if Nkind (Expr_Actual) = N_String_Literal + -- The above also applies to the External_Initializer case. + + if Nkind (Expr_Actual) in N_String_Literal | N_External_Initializer and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype then Cond := diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 322629a..83d3fdb 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -49,8 +49,8 @@ package Checks is record Elements : Bit_Vector (1 .. Dimensions); end record; - Empty_Dimension_Set : constant Dimension_Set - := (Dimensions => 0, Elements => (others => <>)); + Empty_Dimension_Set : constant Dimension_Set := + (Dimensions => 0, Elements => (others => <>)); procedure Initialize; -- Called for each new main source program, to initialize internal diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 2623eed..e411ddb 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -30,6 +30,7 @@ with Atree; use Atree; with Debug; use Debug; with Errout; use Errout; +with Generate_Minimal_Reproducer; with Gnatvsn; use Gnatvsn; with Lib; use Lib; with Namet; use Namet; @@ -263,7 +264,7 @@ package body Comperr is Src : Source_Buffer_Ptr; begin - Namet.Unlock; + Namet.Unlock_If_Locked; Name_Buffer (1 .. 12) := "gnat_bug.box"; Name_Len := 12; Read_Source_File (Name_Enter, 0, Hi, Src, FD); @@ -403,6 +404,14 @@ package body Comperr is Write_Str ("list may be incomplete"); end; + begin + if Debug_Flag_Underscore_M then + Generate_Minimal_Reproducer; + end if; + exception + when others => null; + end; + Write_Eol; Set_Standard_Output; @@ -539,5 +548,4 @@ package body Comperr is Write_Char (After); end Repeat_Char; - end Comperr; diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 6b45d25..d2e4a6b 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1334,8 +1334,8 @@ package body CStand is -- used internally. They are unsigned types with the same length as -- the correspondingly named signed integer types. - Standard_Short_Short_Unsigned - := New_Standard_Entity ("short_short_unsigned"); + Standard_Short_Short_Unsigned := + New_Standard_Entity ("short_short_unsigned"); Build_Unsigned_Integer_Type (Standard_Short_Short_Unsigned, Standard_Short_Short_Integer_Size); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index fcd04df..3dbf3a7b 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -150,7 +150,7 @@ package body Debug is -- d_j Read JSON files and populate Repinfo tables (opposite of -gnatRjs) -- d_k In CodePeer mode disable expansion of assertion checks -- d_l Disable strict alignment of array types with aliased component - -- d_m + -- d_m Run adareducer on crash -- d_n -- d_o -- d_p Ignore assertion pragmas for elaboration @@ -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 @@ -177,7 +177,7 @@ package body Debug is -- d_J -- d_K (Reserved) Enable reporting a warning on known-problem issues -- d_L Output trace information on elaboration checking - -- d_M + -- d_M Ignore Source_File_Name and Source_File_Name_Project pragmas -- d_N -- d_O -- d_P 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..ce130cc --- /dev/null +++ b/gcc/ada/diagnostics-constructors.adb @@ -0,0 +1,514 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; + + ------------------------------------------ + -- Make_Mixed_Container_Aggregate_Error -- + ------------------------------------------ + + function Make_Mixed_Container_Aggregate_Error + (Aggr : Node_Id; + Pos_Elem : Node_Id; + Named_Elem : Node_Id) return Diagnostic_Type + is + + begin + return + Make_Diagnostic + (Msg => + "container aggregate cannot be both positional and named", + Location => Primary_Labeled_Span (Aggr), + Id => GNAT0011, + Kind => Diagnostics.Error, + Spans => + (1 => Secondary_Labeled_Span + (Pos_Elem, "positional element "), + 2 => Secondary_Labeled_Span + (Named_Elem, "named element"))); + end Make_Mixed_Container_Aggregate_Error; + + -------------------------------------------- + -- Record_Mixed_Container_Aggregate_Error -- + -------------------------------------------- + + procedure Record_Mixed_Container_Aggregate_Error + (Aggr : Node_Id; + Pos_Elem : Node_Id; + Named_Elem : Node_Id) + is + begin + Record_Diagnostic + (Make_Mixed_Container_Aggregate_Error (Aggr, Pos_Elem, Named_Elem)); + end Record_Mixed_Container_Aggregate_Error; + +end Diagnostics.Constructors; diff --git a/gcc/ada/diagnostics-constructors.ads b/gcc/ada/diagnostics-constructors.ads new file mode 100644 index 0000000..973d176 --- /dev/null +++ b/gcc/ada/diagnostics-constructors.ads @@ -0,0 +1,143 @@ +------------------------------------------------------------------------------ +-- -- +-- 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); + + function Make_Mixed_Container_Aggregate_Error + (Aggr : Node_Id; + Pos_Elem : Node_Id; + Named_Elem : Node_Id) return Diagnostic_Type; + + procedure Record_Mixed_Container_Aggregate_Error + (Aggr : Node_Id; + Pos_Elem : Node_Id; + Named_Elem : Node_Id); + +end Diagnostics.Constructors; diff --git a/gcc/ada/diagnostics-converter.adb b/gcc/ada/diagnostics-converter.adb 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..ae8dc68 --- /dev/null +++ b/gcc/ada/diagnostics-repository.ads @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- 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), + GNAT0011 => + (Status => Active, + Human_Id => new String'("Mixed_Container_Aggregate_Error"), + Documentation => new String'("./error_codes/GNAT0011.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..f456927 --- /dev/null +++ b/gcc/ada/diagnostics.ads @@ -0,0 +1,482 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, + GNAT0011); + + -- Labeled_Span_Type represents a span of source code that is associated + -- with a textual label. Primary spans indicate the primary location of the + -- diagnostic. Non-primary spans are used to indicate secondary locations. + -- + -- Spans can contain labels that are used to annotate the highlighted span. + -- Usually, the label is a short and concise message that provide + -- additional allthough non-critical information about the span. This is + -- an important since labels are not printed in the brief output and are + -- only present in the pretty and structural outputs. That is an important + -- distintion when choosing between a label and a sub-diagnostic. + type Labeled_Span_Type is record + Label : String_Ptr := null; + -- Text associated with the span + + Span : Source_Span := (others => No_Location); + -- Textual region in the source code + + Is_Primary : Boolean := True; + -- Primary spans are used to indicate the primary location of the + -- diagnostic. Typically there should just be one primary span per + -- diagnostic. + -- Non-primary spans are used to indicate secondary locations and + -- typically are formatted in a different way or omitted in some + -- contexts. + + Is_Region : Boolean := False; + -- Regional spans are multiline spans that have a unique way of being + -- displayed in the pretty output. + end record; + + No_Labeled_Span : constant Labeled_Span_Type := (others => <>); + + procedure Destroy (Elem : in out Labeled_Span_Type); + pragma Inline (Destroy); + + package Labeled_Span_Lists is new Doubly_Linked_Lists + (Element_Type => Labeled_Span_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + subtype Labeled_Span_List is Labeled_Span_Lists.Doubly_Linked_List; + + type Sub_Diagnostic_Kind is + (Continuation, + Help, + Note, + Suggestion); + + -- Sub_Diagnostic_Type represents a sub-diagnostic message that is meant + -- to provide additional information about the primary diagnostic message. + -- + -- Sub-diagnostics are usually constructed with a full sentence as the + -- message and provide important context to the main diagnostic message or + -- some concrete action to the user. + -- + -- This is different from the labels of labeled spans which are meant to be + -- short and concise and are mostly there to annotate the higlighted span. + + type Sub_Diagnostic_Type is record + Kind : Sub_Diagnostic_Kind; + + Message : String_Ptr; + + Locations : Labeled_Span_List; + end record; + + procedure Add_Location + (Diagnostic : in out Sub_Diagnostic_Type; Location : Labeled_Span_Type); + + function Primary_Location + (Diagnostic : Sub_Diagnostic_Type) return Labeled_Span_Type; + + procedure Destroy (Elem : in out Sub_Diagnostic_Type); + pragma Inline (Destroy); + + package Sub_Diagnostic_Lists is new Doubly_Linked_Lists + (Element_Type => Sub_Diagnostic_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Sub_Diagnostic_List is Sub_Diagnostic_Lists.Doubly_Linked_List; + + -- An Edit_Type represents a textual edit that is associated with a Fix. + type Edit_Type is record + Span : Source_Span; + -- Region of the file to be removed + + Text : String_Ptr; + -- Text to be inserted at the start location of the span + end record; + + procedure Destroy (Elem : in out Edit_Type); + pragma Inline (Destroy); + + package Edit_Lists is new Doubly_Linked_Lists + (Element_Type => Edit_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Edit_List is Edit_Lists.Doubly_Linked_List; + + -- Type Applicability_Type will indicate the state of the resulting code + -- after applying a fix. + -- * Option Has_Placeholders indicates that the fix contains placeholders + -- that the user would need to fill. + -- * Option Legal indicates that applying the fix will result in legal Ada + -- code. + -- * Option Possibly_Illegal indicates that applying the fix will result in + -- possibly legal, but also possibly illegal Ada code. + type Applicability_Type is + (Has_Placeholders, + Legal, + Possibly_Illegal, + Unspecified); + + type Fix_Type is record + Description : String_Ptr := null; + -- Message describing the fix that will be displayed to the user. + + Applicability : Applicability_Type := Unspecified; + + Edits : Edit_List; + -- File changes for the fix. + end record; + + procedure Destroy (Elem : in out Fix_Type); + pragma Inline (Destroy); + + package Fix_Lists is new Doubly_Linked_Lists + (Element_Type => Fix_Type, + "=" => "=", + Destroy_Element => Destroy, + Check_Tampering => False); + + subtype Fix_List is Fix_Lists.Doubly_Linked_List; + + procedure Add_Edit (Fix : in out Fix_Type; Edit : Edit_Type); + + type Status_Type is + (Active, + Deprecated); + + type Switch_Id is ( + No_Switch_Id, + gnatwb, + gnatwc, + gnatwd, + gnatwf, + gnatwg, + gnatwh, + gnatwi, + gnatwj, + gnatwk, + gnatwl, + gnatwm, + gnatwo, + gnatwp, + gnatwq, + gnatwr, + gnatwt, + gnatwu, + gnatwv, + gnatww, + gnatwx, + gnatwy, + gnatwz, + gnatw_dot_a, + gnatw_dot_b, + gnatw_dot_c, + gnatw_dot_f, + gnatw_dot_h, + gnatw_dot_i, + gnatw_dot_j, + gnatw_dot_k, + gnatw_dot_l, + gnatw_dot_m, + gnatw_dot_n, + gnatw_dot_o, + gnatw_dot_p, + gnatw_dot_q, + gnatw_dot_r, + gnatw_dot_s, + gnatw_dot_t, + gnatw_dot_u, + gnatw_dot_v, + gnatw_dot_w, + gnatw_dot_x, + gnatw_dot_y, + gnatw_dot_z, + gnatw_underscore_a, + gnatw_underscore_c, + gnatw_underscore_j, + gnatw_underscore_l, + gnatw_underscore_p, + gnatw_underscore_q, + gnatw_underscore_r, + gnatw_underscore_s, + gnaty, + gnatya, + gnatyb, + gnatyc, + gnatyd, + gnatye, + gnatyf, + gnatyh, + gnatyi, + gnatyk, + gnatyl, + gnatym, + gnatyn, + gnatyo, + gnatyp, + gnatyr, + gnatys, + gnatyu, + gnatyx, + gnatyz, + gnatyaa, + gnatybb, + gnatycc, + gnatydd, + gnatyii, + gnatyll, + gnatymm, + gnatyoo, + gnatyss, + gnatytt, + gnatel + ); + + subtype Active_Switch_Id is Switch_Id range gnatwb .. gnatel; + -- The range of switch ids that represent switches that trigger a specific + -- diagnostic check. + + type Switch_Type is record + + Status : Status_Type := Active; + -- The status will indicate whether the switch is currently active, + -- or has been deprecated. A deprecated switch will not control + -- diagnostics, and will not be emitted by the GNAT usage. + + Human_Id : String_Ptr := null; + -- The Human_Id will be a unique and stable string-based ID which + -- identifies the content of the switch within the switch registry. + -- This ID will appear in SARIF readers. + + Short_Name : String_Ptr := null; + -- The Short_Name will denote the -gnatXX name of the switch. + + Description : String_Ptr := null; + -- The description will contain the description of the switch, as it is + -- currently emitted by the GNAT usage. + + Documentation_Url : String_Ptr := null; + -- The documentation_url will point to the AdaCore documentation site + -- for the switch. + + end record; + + type Diagnostic_Kind is + (Error, + 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 32f00c0..cccf602 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,12 +47,18 @@ 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 -------------------------------- -A basic_declarative_item may appear at the place of any statement. -This avoids the heavy syntax of block_statements just to declare -something locally. +A ``basic_declarative_item`` may appear at the place of any statement. This +avoids the heavy syntax of block_statements just to declare something locally. + +The only valid kind of declarations for now are ``object_declaration``, +``object_renaming_declaration``, ``use_package_clause`` and +``use_type_clause``. For example: @@ -65,79 +72,63 @@ For example: X := X + Squared; end if; -Link to the original RFC: -https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-local-vars-without-block.md - -Conditional when constructs ---------------------------- - -This feature extends the use of ``when`` as a way to condition a control-flow -related statement, to all control-flow related statements. - -To do a conditional return in a procedure the following syntax should be used: - -.. code-block:: ada - - procedure P (Condition : Boolean) is - begin - return when Condition; - end; - -This will return from the procedure if ``Condition`` is true. - -When being used in a function the conditional part comes after the return value: - -.. code-block:: ada - - function Is_Null (I : Integer) return Boolean is - begin - return True when I = 0; - return False; - end; - -In a similar way to the ``exit when`` a ``goto ... when`` can be employed: +It is generally a good practice to declare local variables (or constants) with as +short a lifetime as possible. However, introducing a declare block to accomplish +this is a relatively heavy syntactic load along with a traditional extra level +of indentation. The alternative syntax supported here allows declaring symbols +in any statement sequence. Lifetime of such local declarations is until the end of +the enclosing construct. The same enclosing construct cannot contain several +declarations of the same symbol; however, overriding symbols from higher-level +scopes works similarly to the explicit ``declare`` block. -.. code-block:: ada +If the enclosing construct allows an exception handler (such as an accept +statement, begin-except-end block or a subprogram body), declarations that +appear at the place of a statement are *not* visible within the handler. Only +declarations that precede the beginning of the construct with an exception +handler would be visible in this handler. - procedure Low_Level_Optimized is - Flags : Bitmapping; - begin - Do_1 (Flags); - goto Cleanup when Flags (1); +.. attention:: - Do_2 (Flags); - goto Cleanup when Flags (32); + Here are a couple of examples illustrating the scoping rules described above. - -- ... + 1. Those declarations are not visible from the potential exception handler: - <<Cleanup>> - -- ... - end; + .. code-block:: ada -.. code-block + begin + A : Integer + ... + exception + when others => + Put_Line (A'Image) -- ILLEGAL + end; -To use a conditional raise construct: + 2. The following is legal -.. code-block:: ada + .. code-block:: ada - procedure Foo is - begin - raise Error when Imported_C_Func /= 0; - end; + declare + A : Integer := 10; + begin + A : Integer := 12; + end; -An exception message can also be added: + because it is roughly expanded into -.. code-block:: ada + .. code-block:: ada - procedure Foo is - begin - raise Error with "Unix Error" - when Imported_C_Func /= 0; - end; + declare + A : Integer := 10; + begin + declare + A : Integer := 12; + begin + ... + end; + end; + And as such the second ``A`` declaration is hiding the first one. -Link to the original RFC: -https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-conditional-when-constructs.rst Fixed lower bounds for array types and subtypes ----------------------------------------------- @@ -185,9 +176,6 @@ the efficiency of indexing operations, since the compiler statically knows the lower bound of unconstrained array formals when the formal's subtype has index ranges with static fixed lower bounds. -Link to the original RFC: -https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-fixed-lower-bound.rst - Prefixed-view notation for calls to primitive subprograms of untagged types --------------------------------------------------------------------------- @@ -202,7 +190,7 @@ This same notation is already available for tagged types. This extension allows for untagged types. It is allowed for all primitive operations of the type independent of whether they were originally declared in a package spec or its private part, or were inherited and/or overridden as part of a derived type -declaration occuring anywhere, so long as the first parameter is of the type, +declaration occurring anywhere, so long as the first parameter is of the type, or an access parameter designating the type. For example: @@ -236,9 +224,6 @@ For example: pragma Assert (V.Length = 2); pragma Assert (V.Nth_Element(1) = 42); -Link to the original RFC: -https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-prefixed-untagged.rst - Expression defaults for generic formal functions ------------------------------------------------ @@ -263,6 +248,11 @@ Here is an example of this feature: -- ... end Stacks; +.. todo:: + + I do not understand this feature enough to decide if the description above + is sufficient for documentation. + Link to the original RFC: https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-expression-functions-as-default-for-generic-formal-function-parameters.rst @@ -324,9 +314,6 @@ For example: f" a double quote is \" and" & f" an open brace is \{"); -Link to the original RFC: -https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-string-interpolation.md - Constrained attribute for generic objects ----------------------------------------- @@ -340,23 +327,420 @@ The Ada 202x ``Static`` aspect can be specified on Intrinsic imported functions and the compiler will evaluate some of these intrinsics statically, in particular the ``Shift_Left`` and ``Shift_Right`` intrinsics. +First Controlling Parameter +--------------------------- + +A new pragma/aspect, ``First_Controlling_Parameter``, is introduced for tagged +types, altering the semantics of primitive/controlling parameters. When a +tagged type is marked with this aspect, only subprograms where the first +parameter is of that type will be considered dispatching primitives. This +pragma/aspect applies to the entire hierarchy, starting from the specified +type, without affecting inherited primitives. + +Here is an example of this feature: + +.. code-block:: ada + + package Example is + type Root is tagged private; + + procedure P (V : Integer; V2 : Root); + -- Primitive + + type Child is tagged private + with First_Controlling_Parameter; + + private + type Root is tagged null record; + type Child is new Root with null record; + + overriding + procedure P (V : Integer; V2 : Child); + -- Primitive + + procedure P2 (V : Integer; V2 : Child); + -- NOT Primitive + + function F return Child; -- NOT Primitive + + function F2 (V : Child) return Child; + -- Primitive, but only controlling on the first parameter + end; + +Note that ``function F2 (V : Child) return Child;`` differs from ``F2 (V : Child) +return Child'Class;`` in that the return type is a specific, definite type. This +is also distinct from the legacy semantics, where further derivations with +added fields would require overriding the function. + +The option ``-gnatw_j``, that you can pass to the compiler directly, enables +warnings related to this new language feature. For instance, compiling the +example above without this switch produces no warnings, but compiling it with +``-gnatw_j`` generates the following warning on the declaration of procedure P2: + +.. code-block:: ada + + warning: not a dispatching primitive of tagged type "Child" + warning: disallowed by First_Controlling_Parameter on "Child" + +For generic formal tagged types, you can specify whether the type has the +First_Controlling_Parameter aspect enabled: + +.. code-block:: ada + + generic + type T is tagged private with First_Controlling_Parameter; + package T is + type U is new T with null record; + function Foo return U; -- Not a primitive + end T; + +For tagged partial views, the value of the aspect must be consistent between +the partial and full views: + +.. code-block:: ada + + package R is + type T is tagged private; + ... + private + type T is tagged null record with First_Controlling_Parameter; -- ILLEGAL + end R; + +Restricting the position of controlling parameter offers several advantages: + +* Simplification of the dispatching rules improves readability of Ada programs. + One doesn't need to analyze all subprogram parameters to understand if the given + subprogram is a primitive of a certain tagged type. + +* A programmer is free to use any type, including classwide types, on other + parameters of a subprogram, without the need to consider possible effects of + overriding a primitive or creating new one. + +* Return type of a function is never considered as a controlling parameter. + + .. _Experimental_Language_Extensions: Experimental Language Extensions ================================ +Features activated via ``-gnatX0`` or +``pragma Extensions_Allowed (All_Extensions)``. + +Conditional when constructs +--------------------------- + +This feature extends the use of ``when`` as a way to condition a control-flow +related statement, to all control-flow related statements. + +To do a conditional return in a procedure the following syntax should be used: + +.. code-block:: ada + + procedure P (Condition : Boolean) is + begin + return when Condition; + end; + +This will return from the procedure if ``Condition`` is true. + +When being used in a function the conditional part comes after the return value: + +.. code-block:: ada + + function Is_Null (I : Integer) return Boolean is + begin + return True when I = 0; + return False; + end; + +In a similar way to the ``exit when`` a ``goto ... when`` can be employed: + +.. code-block:: ada + + procedure Low_Level_Optimized is + Flags : Bitmapping; + begin + Do_1 (Flags); + goto Cleanup when Flags (1); + + Do_2 (Flags); + goto Cleanup when Flags (32); + + -- ... + + <<Cleanup>> + -- ... + end; + +.. code-block + +To use a conditional raise construct: + +.. code-block:: ada + + procedure Foo is + begin + raise Error when Imported_C_Func /= 0; + end; + +An exception message can also be added: + +.. code-block:: ada + + procedure Foo is + begin + raise Error with "Unix Error" + when Imported_C_Func /= 0; + end; + Storage Model ------------- -This feature proposes to redesign the concepts of Storage Pools into a more -efficient model allowing higher performances and easier integration with low -footprint embedded run-times. +This extends Storage Pools into a more efficient model allowing higher performances, +easier integration with low footprint embedded run-times and copying data between +different pools of memory. The latter is especially useful when working with distributed +memory models, in particular to support interactions with GPU. + +Aspect Storage_Model_Type +^^^^^^^^^^^^^^^^^^^^^^^^^^ + +A Storage model is a type which is associated with an aspect +"Storage_Model_Type", e.g.: + +.. code-block:: Ada + + type A_Model is null record + with Storage_Model_Type; + +Storage_Model_Type itself accepts six parameters: + +- Address_Type, the type of the address managed by this model. This has to be + a scalar type or derived from System.Address. +- Allocate, a procedure used for allocating memory in this model +- Deallocate, a procedure used for deallocating memory in this model +- Copy_To, a procedure used to copy memory from native memory to this model +- Copy_From, a procedure used to copy memory from this model to native memory +- Storage_Size, a function returning the amount of memory left +- Null_Address, a value for the null address value + +By default, Address_Type is System.Address, and all other five subprograms are +performing native operations (e.g. the allocator is the native new allocator). +Users can decide to specify one or more of these. When an Address_Type is +specified and different than System.Address, the all other five subprograms have +to be specified. + +The prototypes of these procedures are as follows: + +.. code-block:: Ada + + procedure Allocate + (Model : in out A_Model; + Storage_Address : out Address_Type; + Size : Storage_Count; + Alignment : Storage_Count); + + procedure Deallocate + (Model : in out A_Model; + Storage_Address : out Address_Type; + Size : Storage_Count; + Alignment : Storage_Count); + + procedure Copy_To + (Model : in out A_Model; + Target : Address_Type; + Source : System.Address; + Size : Storage_Count); + + procedure Copy_From + (Model : in out A_Model; + Target : System.Address; + Source : Address_Type; + Size : Storage_Count); + + function Storage_Size + (Pool : A_Model) + return Storage_Count; + +Here's an example of how this could be instantiated in the context of CUDA: + +.. code-block:: Ada + + package CUDA_Memory is + + type CUDA_Storage_Model is null record + with Storage_Model_Type => ( + Address_Type => CUDA_Address, + Allocate => CUDA_Allocate, + Deallocate => CUDA_Deallocate, + Copy_To => CUDA_Copy_To, + Copy_From => CUDA_Copy_From, + Storage_Size => CUDA_Storage_Size, + Null_Address => CUDA_Null_Address + ); + + type CUDA_Address is new System.Address; + -- We're assuming for now same address size on host and device + + procedure CUDA_Allocate + (Model : in out CUDA_Storage_Model; + Storage_Address : out CUDA_Address; + Size : Storage_Count; + Alignment : Storage_Count); + + procedure CUDA_Deallocate + (Model : in out CUDA_Storage_Model; + Storage_Address : out CUDA_Address; + Size : Storage_Count; + Alignment : Storage_Count); + + procedure CUDA_Copy_To + (Model : in out CUDA_Storage_Model; + Target : CUDA_Address; + Source : System.Address; + Size : Storage_Count); + + procedure CUDA_Copy_From + (Model : in out CUDA_Storage_Model; + Target : System.Address; + Source : CUDA_Address; + Size : Storage_Count); + + function CUDA_Storage_Size + (Pool : CUDA_Storage_Model) + return Storage_Count return Storage_Count'Last; + + CUDA_Null_Address : constant CUDA_Address := + CUDA_Address (System.Null_Address); + + CUDA_Memory : CUDA_Storage_Model; + + end CUDA_Memory; + +Aspect Designated_Storage_Model +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +A new aspect, Designated_Storage_Model, allows to specify the memory model +for the objects pointed by an access type. Under this aspect, allocations +and deallocations will come from the specified memory model instead +of the standard ones. In addition, if write operations are needed for +initialization, or if there is a copy of the target object from and to a +standard memory area, the Copy_To and Copy_From functions will be called. +It allows to encompass the capabilities of storage pools, e.g.: + +.. code-block:: Ada + + procedure Main is + type Integer_Array is array (Integer range <>) of Integer; + + type Host_Array_Access is access all Integer_Array; + type Device_Array_Access is access Integer_Array + with Designated_Storage_Model => CUDA_Memory; + + procedure Free is new Unchecked_Deallocation + (Host_Array_Type, Host_Array_Access); + procedure Free is new Unchecked_Deallocation + (Device_Array_Type, Device_Array_Access); + + Host_Array : Host_Array_Access := new Integer_Array (1 .. 10); + + Device_Array : Device_Array_Access := new Host_Array (1 .. 10); + -- Calls CUDA_Storage_Model.Allocate to allocate the fat pointers and + -- the bounds, then CUDA_Storage_Model.Copy_In to copy the values of the + -- boundaries. + begin + Host_Array.all := (others => 0); + + Device_Array.all := Host_Array.all; + -- Calls CUDA_Storage_Model.Copy_To to write to the device array from the + -- native memory. + + Host_Array.all := Device_Array.all; + -- Calls CUDA_Storage_Model.Copy_From to read from the device array and + -- write to native memory. + + Free (Host_Array); + + Free (Device_Array); + -- Calls CUDA_Storage_Model.Deallocate; + end; + +Taking 'Address of an object with a specific memory model returns an object of +the type of the address for that memory category, which may be different from +System.Address. + +When copying is performed between two specific memory models, the native memory +is used as a temporary between the two. E.g.: + +.. code-block:: Ada + + type Foo_I is access Integer with Designated_Storage_Model => Foo; + type Bar_I is access Integer with Designated_Storage_Model => Bar; -It also extends it to support distributed memory models, in particular to -support interactions with GPU. + X : Foo_I := new Integer; + Y : Bar_I := new Integer; + begin + X.all := Y.all; + +conceptually becomes: + +.. code-block:: Ada + + X : Foo_I := new Integer; + T : Integer; + Y : Bar_I := new Integer; + begin + T := Y.all; + X.all := T; + +Legacy Storage Pools +^^^^^^^^^^^^^^^^^^^^^ + +Legacy Storage Pools are now replaced by a Storage_Model_Type. +They are implemented as follows: + +.. code-block:: Ada + + type Root_Storage_Pool is abstract + new Ada.Finalization.Limited_Controlled with private + with Storage_Model_Type => ( + Allocate => Allocate, + Deallocate => Deallocate, + Storage_Size => Storage_Size + ); + pragma Preelaborable_Initialization (Root_Storage_Pool); + + procedure Allocate + (Pool : in out Root_Storage_Pool; + Storage_Address : out System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is abstract; + + procedure Deallocate + (Pool : in out Root_Storage_Pool; + Storage_Address : System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is abstract; + + function Storage_Size + (Pool : Root_Storage_Pool) + return System.Storage_Elements.Storage_Count + is abstract; + +The legacy notation: -Here is a link to the full RFC: -https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-storage-model.rst +.. code-block:: Ada + + type My_Pools is new Root_Storage_Pool with record [...] + + My_Pool_Instance : Storage_Model_Pool.Storage_Model := + My_Pools'(others => <>); + + type Acc is access Integer_Array with Storage_Pool => My_Pool; + +can still be accepted as a shortcut for the new syntax. Attribute Super --------------- @@ -365,8 +749,7 @@ Attribute Super The ``Super`` attribute can be applied to objects of tagged types in order to obtain a view conversion to the most immediate specific parent type. -It cannot be applied to objects of types without any ancestors, or types whose -immediate parent is abstract. +It cannot be applied to objects of types without any ancestors. .. code-block:: ada @@ -374,36 +757,304 @@ immediate parent is abstract. procedure P (V : T1); type T2 is new T1 with null record; - procedure P (V : T2); - procedure Call (V : T2'Class) is + type T3 is new T2 with null record; + procedure P (V : T3); + + procedure Call ( + V1 : T1'Class; + V2 : T2'Class; + V3 : T3'Class) is begin - V'Super.P; -- Equivalent to "P (T1 (V));", a nondispatching call - -- to T1's primitive procedure P. + V1'Super.P; -- Illegal call as T1 doesn't have any ancestors + V2'Super.P; -- Equivalent to "T1 (V).P;", a non-dispatching call + -- to T1's primitive procedure P. + V3'Super.P; -- Equivalent to "T2 (V).P;"; Since T2 doesn't + -- override P, a non-dispatching call to T1.P is + -- executed. end; -Here is a link to the full RFC: -https://github.com/QuentinOchem/ada-spark-rfcs/blob/oop/considered/rfc-oop-super.rst - Simpler accessibility model --------------------------- -The goal of this feature is to restore a common understanding of accessibility -rules for implementers and users alike. The new rules should both be effective -at preventing errors and feel natural and compatible in an Ada environment -while removing dynamic accessibility checking. +The goal of this feature is to simplify the accessibility rules by removing +dynamic accessibility checks that are often difficult to understand and debug. +The new rules are effective at preventing errors, at the expense of loosing +some flexibility in the use of anonymous access types. + +The feature can be activated with pragma "No_Dynamic_Accessibility_Checks". +As a result, a set of restrictions apply that can be categorized into three +use-case of anonymous access types: + +* standalone objects, +* subprogam parameters and +* function results. + +Each of those use-cases is explained separately below. All of the refined rules are +compatible with the [use of anonymous access types in SPARK] +(http://docs.adacore.com/spark2014-docs/html/lrm/declarations-and-types.html#access-types). + + +Standalone objects +^^^^^^^^^^^^^^^^^^ + +.. code-block:: ada + + Var : access T := ... + Var_To_Cst : access constant T := ... + Cst : constant access T := ... + Cst_To_Cst : constant access constant T := ... + +The accessibility levels of standalone objects of anonymous access type (both +constants or variables) is derived of the level of their object declaration. +This supports many common use-cases without the employment of ``Unchecked_Access`` +while still removing the need for dynamic checks. + +The most major benefit of this change is the compatibility with standard Ada rules. + +For example, the following assignment is legal without ``Unchecked_Access`` that +would be required without using the No_Dynamic_Accessibility_Checks pragma: + +.. code-block:: ada + + pragma Restrictions (No_Dynamic_Accessibility_Checks); + + procedure Accessibility is + + type T is null record; + type T_Ptr is access all T; + + T_Inst : aliased T; + Anon : access T := T_Inst'Access; + Named : T_Ptr := Anon; + + begin + null; + end; + +Subprogram parameters +^^^^^^^^^^^^^^^^^^^^^^ + +.. code-block:: ada + + procedure P (V : access T; X : access constant T); + + +When the type of a formal parameter is of anonymous access then, from the caller's +perspective, its level is seen to be at least as deep as that of the type of the +corresponding actual parameter (whatever that actual parameter might be) - +meaning any actual can be used for an anonymous access parameter without the use +of 'Unchecked_Access. + +.. todo:: + + the example below doesn't demonstrate the feature -- X'Access is legal in plain Ada. + +.. code-block:: ada + + pragma Restrictions (No_Dynamic_Accessibility_Checks); + + procedure Accessibility is + + procedure Foo (Param : access Integer) is null; + X : aliased Integer; + begin + Foo (X'Access); + end; + +From the callee's perspective, the level of anonymous access formal parameters would be +between the level of the subprogram and the level of the subprogram's locals. This has the effect +of formal parameters being treated as local to the callee except in: + +* Use as a function result +* Use as a value for an access discriminant in result object +* Use as an assignments between formal parameters + +Note that with these more restricted rules we lose track of accessibility levels when assigned to +local objects thus making (in the example below) the assignment to Node2.Link from Temp below +compile-time illegal. + +.. todo:: + + the code below gives the same error messages with and without the pragma + +.. code-block:: ada + + type Node is record + Data : Integer; + Link : access Node; + end record; + + procedure Swap_Links (Node1, Node2 : in out Node) is + Temp : constant access Integer := Node1.Link; -- We lose the "association" to Node1 + begin + Node1.Link := Node2.Link; -- Allowed + Node2.Link := Temp; -- Not allowed + end; + + function Identity (N : access Node) return access Node is + Local : constant access Node := N; + begin + if True then + return N; -- Allowed + else + return Local; -- Not allowed + end if; + end; + + +Function results +^^^^^^^^^^^^^^^^ + +.. code-block:: ada + + function Get (X : Rec) return access T; + +.. todo:: + + clarify the list/reword + +The accessibility level of the result of a call to a function that has an anonymous access result type defined to be as +whatever is deepest out of the following: + +* The level of the subprogram +* The level of any actual parameter corresponding to a formal parameter of an anonymous access type +* The level of each parameter that has a part with both one or more access discriminants and an unconstrained subtype +* The level of any actual parameter corresponding to a formal parameter which is explicitly aliased + +NOTE: We would need to include an additional item in the list if we were not to enforce the below restriction on tagged types: + +* The level of any actual parameter corresponding to a formal parameter of a tagged type + +Function result example: -Here is a link to the full RFC: -https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-simpler-accessibility.md +.. todo:: + + verify the examples. Clarify, if they define expected behavior with the pragma or general restriction + that is modified by the pragma + +.. code-block:: ada + + declare + type T is record + Comp : aliased Integer; + end record; + + function Identity (Param : access Integer) return access Integer is + begin + return Param; -- Legal + end; + + function Identity_2 (Param : aliased Integer) return access Integer is + begin + return Param'Access; -- Legal + end; + + X : access Integer; + begin + X := Identity (X); -- Legal + declare + Y : access Integer; + Z : aliased Integer; + begin + X := Identity (Y); -- Illegal since Y is too deep + X := Identity_2 (Z); -- Illegal since Z is too deep + end; + end; + +However, an additional restriction that falls out of the above logic is that tagged type extensions *cannot* +allow additional anonymous access discriminants in order to prevent upward conversions potentially making +such "hidden" anonymous access discriminants visible and prone to memory leaks. + +.. todo:: + + verify the examples. Clarify, if they define expected behavior with the pragma or general restriction + that is modified by the pragma + +Here is an example of one such case of an upward conversion which would lead to a memory leak: + +.. code-block:: ada + + declare + type T is tagged null record; + type T2 (Disc : access Integer) is new T with null record; -- Must be illegal + + function Identity (Param : aliased T'Class) return access Integer is + begin + return T2 (T'Class (Param)).Disc; -- Here P gets effectively returned and set to X + end; + + X : access Integer; + begin + declare + P : aliased Integer; + Y : T2 (P'Access); + begin + X := Identity (T'Class (Y)); -- Pass local variable P (via Y's discriminant), + -- leading to a memory leak. + end; + end; + ``` + + Thus we need to make the following illegal to avoid such situations: + + ```ada + package Pkg1 is + type T1 is tagged null record; + function Func (X1 : T1) return access Integer is (null); + end; + + package Pkg2 is + type T2 (Ptr1, Ptr2 : access Integer) is new Pkg1.T1 with null record; -- Illegal + ... + end; + +In order to prevent upward conversions of anonymous function results (like below), we +also would need to assure that the level of such a result (from the callee's perspective) +is statically deeper: + +.. todo:: + + verify the examples. Clarify, if they define expected behavior with the pragma or general restriction + that is modified by the pragma + +.. code-block:: ada + + declare + type Ref is access all Integer; + Ptr : Ref; + function Foo (Param : access Integer) return access Integer is + begin + return Result : access Integer := Param; do + Ptr := Ref (Result); -- Not allowed + end return; + end; + begin + declare + Local : aliased Integer; + begin + Foo (Local'Access).all := 123; + end; + end; + + +Discriminants and allocators +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +.. todo:: + + I have removed this section as it was referring to a feature which was never + implemented by gnat. Double-check that this is correct. Case pattern matching --------------------- -The selector for a case statement (but not yet for a case expression) may be of a composite type, subject to -some restrictions (described below). Aggregate syntax is used for choices -of such a case statement; however, in cases where a "normal" aggregate would -require a discrete value, a discrete subtype may be used instead; box -notation can also be used to match all values. +The selector for a case statement (but not for a case expression) may +be of a composite type, subject to some restrictions (described below). +Aggregate syntax is used for choices of such a case statement; however, +in cases where a "normal" aggregate would require a discrete value, a +discrete subtype may be used instead; box notation can also be used to +match all values. Consider this example: @@ -474,7 +1125,7 @@ matched (and the first one did not), then the actual parameters will be reversed. Within the choice list for single alternative, each choice must define the same -set of bindings and the component subtypes for for a given identifer must all +set of bindings and the component subtypes for for a given identifier must all statically match. Currently, the case of a binding for a nondiscrete component is not implemented. @@ -511,21 +1162,15 @@ compile-time capacity limits in some annoyingly common scenarios; the message generated in such cases is usually "Capacity exceeded in compiling case statement with composite selector type". -Link to the original RFC: -https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-pattern-matching.rst - Mutably Tagged Types with Size'Class Aspect ------------------------------------------- -The `Size'Class` aspect can be applied to a tagged type to specify a size +The ``Size'Class`` aspect can be applied to a tagged type to specify a size constraint for the type and its descendants. When this aspect is specified on a tagged type, the class-wide type of that type is considered to be a "mutably tagged" type - meaning that objects of the class-wide type can have their tag changed by assignment from objects with a different tag. -When the aspect is applied to a type, the size of each of its descendant types -must not exceed the size specified for the aspect. - Example: .. code-block:: ada @@ -537,7 +1182,7 @@ Example: Data_Field : Integer; end record; -- ERROR if Derived_Type exceeds 16 bytes -Class-wide types with a specified `Size'Class` can be used as the type of +Class-wide types with a specified ``Size'Class`` can be used as the type of array components, record components, and stand-alone objects. .. code-block:: ada @@ -545,23 +1190,100 @@ array components, record components, and stand-alone objects. Inst : Base'Class; type Array_of_Base is array (Positive range <>) of Base'Class; -Note: Legality of the `Size'Class` aspect is subject to certain restrictions on -the tagged type, such as being undiscriminated, having no dynamic composite -subcomponents, among others detailed in the RFC. +If the ``Size'Class`` aspect is specified for a type ``T``, then every +specific descendant of ``T`` [redundant: (including ``T``)] -Link to the original RFC: -https://github.com/AdaCore/ada-spark-rfcs/blob/topic/rfc-finally/considered/rfc-class-size.md +- shall have a Size that does not exceed the specified value; and + +- shall be undiscriminated; and + +- shall have no composite subcomponent whose subtype is subject to a + dynamic constraint; and + +- shall have no interface progenitors; and + +- shall not have a tagged partial view other than a private extension; and + +- shall not have a statically deeper accessibility level than that of ``T``. + +In addition to the places where Legality Rules normally apply (see 12.3), +these legality rules apply also in the private part and in the body of an +instance of a generic unit. + +For any subtype ``S`` that is a subtype of a descendant of ``T``, ``S'Class'Size`` is +defined to yield the specified value [redundant:, although ``S'Class'Size`` is +not a static expression]. + +A class-wide descendant of a type with a specified ``Size'Class`` aspect is +defined to be a "mutably tagged" type. Any subtype of a mutably tagged type is, +by definition, a definite subtype (RM 3.3 notwithstanding). Default +initialization of an object of such a definite subtype proceeds as for the +corresponding specific type, except that ``Program_Error`` is raised if the +specific type is abstract. [In particular, the initial tag of the object is +that of the corresponding specific type.] + +An object of a tagged type is defined to be "tag-constrained" if it is + +- an object whose type is not mutably tagged; or + +- a constant object; or + +- a view conversion of a tag-constrained object; or + +- a formal ``in out`` or ``out`` parameter whose corresponding + actual parameter is tag-constrained. + +In the case of an assignment to a tagged variable that +is not tag-constrained, no check is performed that the tag of the value of +the expression is the same as that of the target (RM 5.2 notwithstanding). +Instead, the tag of the target object becomes that of the source object of +the assignment. +An assignment to a composite object similarly copies the tags of any +sub-components of the source object that have a mutably-tagged type. + +The ``Constrained`` attribute is defined for any name denoting an object of a +mutably tagged type (RM 3.7.2 notwithstanding). In this case, the Constrained +attribute yields the value True if the object is tag-constrained and False +otherwise. + +Renaming is not allowed (see 8.5.1) for a type conversion having an operand of +a mutably tagged type ``MT`` and a target type ``TT`` such that ``TT'Class`` +does not cover ``MT``, nor for any part of such an object, nor for any slice +of such an object. This rule also applies in any context where a name is +required to be one for which "renaming is allowed" (for example, see RM 12.4). + +A name denoting a view of a variable of a mutably tagged type shall not +occur as an operative constituent of the prefix of a name denoting a +prefixed view of a callable entity, except as the callee name in a call to +the callable entity. + +For a type conversion between two general access types, either both or neither +of the designated types shall be mutably tagged. For an ``Access`` (or +``Unchecked_Access``) attribute reference, the designated type of the type of the +attribute reference and the type of the prefix of the attribute shall either +both or neither be mutably tagged. + +The execution of a construct is erroneous if the construct has a constituent +that is a name denoting a sub-component of a tagged object and the object's +tag is changed by this execution between evaluating the name and the last use +(within this execution) of the subcomponent denoted by the name. + +If the type of a formal parameter is a specific tagged type then the execution +of the call is erroneous if the tag of the actual is changed while the formal +parameter exists (that is, before leaving the corresponding callable +construct). Generalized Finalization ------------------------ -The `Finalizable` aspect can be applied to any record type, tagged or not, -to specify that it provides the same level of control on the operations of initialization, finalization, and assignment of objects as the controlled +The ``Finalizable`` aspect can be applied to any record type, tagged or not, +to specify that it provides the same level of control on the operations of +initialization, finalization, and assignment of objects as the controlled types (see RM 7.6(2) for a high-level overview). The only restriction is that the record type must be a root type, in other words not a derived type. The aspect additionally makes it possible to specify relaxed semantics for -the finalization operations by means of the `Relaxed_Finalization` setting. +the finalization operations by means of the ``Relaxed_Finalization`` setting. Example: @@ -579,5 +1301,260 @@ Example: procedure Finalize (Obj : in out Ctrl); procedure Initialize (Obj : in out Ctrl); -Link to the original RFC: -https://github.com/AdaCore/ada-spark-rfcs/blob/topic/finalization-rehaul/considered/rfc-generalized-finalization.md +The three procedures have the same profile, taking a single ``in out T`` +parameter. + +We follow the same dynamic semantics as controlled objects: + + - ``Initialize`` is called when an object of type ``T`` is declared without + default expression. + + - ``Adjust`` is called after an object of type ``T`` is assigned a new value. + + - ``Finalize`` is called when an object of type ``T`` goes out of scope (for + stack-allocated objects) or is explicitly deallocated (for heap-allocated + objects). It is also called when on the value being replaced in an + assignment. + +However the following differences are enforced by default when compared to the +current Ada controlled-objects finalization model: + +* No automatic finalization of heap allocated objects: ``Finalize`` is only + called when an object is implicitly deallocated. As a consequence, no-runtime + support is needed for the implicit case, and no header will be maintained for + this in heap-allocated controlled objects. + + Heap-allocated objects allocated through a nested access type definition will + hence **not** be deallocated either. The result is simply that memory will be + leaked in those cases. + +* The ``Finalize`` procedure should have have the :ref:`No_Raise_Aspect` specified. + If that's not the case, a compilation error will be raised. + +Additionally, two other configuration aspects are added, +``Legacy_Heap_Finalization`` and ``Exceptions_In_Finalize``: + +* ``Legacy_Heap_Finalization``: Uses the legacy automatic finalization of + heap-allocated objects + +* ``Exceptions_In_Finalize``: Allow users to have a finalizer that raises exceptions + **NB!** note that using this aspect introduces execution time penalities. + +.. _No_Raise_Aspect: + +No_Raise aspect +---------------- + +The ``No_Raise`` aspect can be applied to a subprogram to declare that this subprogram is not +expected to raise any exceptions. Should an exception still occur during the execution of +this subpropgram, ``Program_Error`` is raised. + +New specification for ``Ada.Finalization.Controlled`` +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +``Ada.Finalization.Controlled`` is now specified as: + +.. code-block:: ada + + type Controlled is abstract tagged null record + with Initialize => Initialize, + Adjust => Adjust, + Finalize => Finalize, + Legacy_Heap_Finalization, Exceptions_In_Finalize; + + procedure Initialize (Self : in out Controlled) is abstract; + procedure Adjust (Self : in out Controlled) is abstract; + procedure Finalize (Self : in out Controlled) is abstract; + + +### Examples + +A simple example of a ref-counted type: + +.. code-block:: ada + + type T is record + Value : Integer; + Ref_Count : Natural := 0; + end record; + + procedure Inc_Ref (X : in out T); + procedure Dec_Ref (X : in out T); + + type T_Access is access all T; + + type T_Ref is record + Value : T_Access; + end record + with Adjust => Adjust, + Finalize => Finalize; + + procedure Adjust (Ref : in out T_Ref) is + begin + Inc_Ref (Ref.Value); + end Adjust; + + procedure Finalize (Ref : in out T_Ref) is + begin + Def_Ref (Ref.Value); + end Finalize; + + +A simple file handle that ensures resources are properly released: + +.. code-block:: ada + + package P is + type File (<>) is limited private; + + function Open (Path : String) return File; + + procedure Close (F : in out File); + private + type File is limited record + Handle : ...; + end record + with Finalize => Close; + + +Finalized tagged types +^^^^^^^^^^^^^^^^^^^^^^^ + +Aspects are inherited by derived types and optionally overriden by those. The +compiler-generated calls to the user-defined operations are then +dispatching whenever it makes sense, i.e. the object in question is of +classwide type and the class includes at least one finalized-type. + +However note that for simplicity, it is forbidden to change the value of any of +those new aspects in derived types. + +Composite types +^^^^^^^^^^^^^^^ + +When a finalized type is used as a component of a composite type, the latter +becomes finalized as well. The three primitives are derived automatically +in order to call the primitives of their components. + +If that composite type was already user-finalized, then the compiler +calls the primitives of the components so as to stay consistent with today's +controlled types's behavior. + +So, ``Initialize`` and ``Adjust`` are called on components before they +are called on the composite object, but ``Finalize`` is called on the composite +object first. + +Interoperability with controlled types +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +As a consequence of the redefinition of the ``Controlled`` type as a base type +with the new aspects defined, interoperability with controlled type naturally +follows the definition of the above rules. In particular: + +* It is possible to have a new finalized type have a controlled type + component +* It is possible to have a controlled type have a finalized type + component + + +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 discriminants, 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); + + +External_Initialization Aspect +------------------------------ + +The ``External_Initialization`` aspect provides a feature similar to Rust's ``include_bytes!`` +and to C23's ``#embed``. It has the effect of initializing an object with the contents of +a file specified by a file path. + +Only string objects and objects of type ``Ada.Streams.Stream_Element_Array`` can be subject +to the ``External_Initialization`` aspect. + +Example: + +.. code-block:: ada + + with Ada.Streams; + + package P is + S : constant String with External_Initialization => "foo.txt"; + + X : constant Ada.Streams.Stream_Element_Array with External_Initialization => "bar.bin"; + end P; + +``External_Initialization`` aspect accepts the following parameters: + +- mandatory ``Path``: the path the compiler uses to access the binary resource; +- optional ``Maximum_Size``: the maximum number of bytes the compiler reads from + the resource; +- optional ``If_Empty``: an expression used in place of read data in case + the resource is empty; + +``Path`` is resolved according to the same rules the compiler uses for loading the source files. + +.. attention:: The maximum size of loaded files is limited to 2\ :sup:`31` bytes. 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 ce3ed0c..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 @@ -3430,6 +3430,23 @@ of the pragma in the :title:`GNAT_Reference_manual`). This switch suppresses listing of inherited aspects. +.. index:: -gnatw_l (gcc) + +:switch:`-gnatw_l` + *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. + + +.. index:: -gnatw_L (gcc) + +:switch:`-gnatw_L` + *Suppress warnings on implicitly limited types.* + + This switch suppresses warnings on implicitly limited types. + + .. index:: -gnatwm (gcc) :switch:`-gnatwm` @@ -4766,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; @@ -4777,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/einfo.ads b/gcc/ada/einfo.ads index 4486ab3..2fb4570 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1651,6 +1651,11 @@ package Einfo is -- that this does not imply a representation with holes, since the rep -- clause may merely confirm the default 0..N representation. +-- Has_First_Controlling_Parameter_Aspect +-- Defined in tagged types, concurrent types and concurrent record types. +-- Set to indicate that the type has a First_Controlling_Parameter of +-- True (whether by an aspect_specification, a pragma, or inheritance). + -- Has_Exit -- Defined in loop entities. Set if the loop contains an exit statement. @@ -5973,6 +5978,7 @@ package Einfo is -- First_Entity -- Corresponding_Record_Type -- Entry_Bodies_Array + -- Has_First_Controlling_Parameter_Aspect -- Last_Entity -- Discriminant_Constraint -- Scope_Depth_Value @@ -6014,6 +6020,7 @@ package Einfo is -- Component_Alignment (special) (base type only) -- C_Pass_By_Copy (base type only) -- Has_Dispatch_Table (base tagged type only) + -- Has_First_Controlling_Parameter_Aspect -- Has_Pragma_Pack (impl base type only) -- Has_Private_Ancestor -- Has_Private_Extension @@ -6049,6 +6056,7 @@ package Einfo is -- Underlying_Record_View $$$ (base type only) -- Predicated_Parent (subtype only) -- Has_Completion + -- Has_First_Controlling_Parameter_Aspect -- Has_Private_Ancestor -- Has_Private_Extension -- Has_Record_Rep_Clause (base type only) @@ -6144,6 +6152,7 @@ package Einfo is -- Corresponding_Record_Type -- Last_Entity -- Discriminant_Constraint + -- Has_First_Controlling_Parameter_Aspect -- Scope_Depth_Value -- Stored_Constraint -- Task_Body_Procedure diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index c8d87f0..81919a3 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 @@ -1875,6 +1869,8 @@ package body Errout is | N_Declaration | N_Access_To_Subprogram_Definition | N_Generic_Instantiation + | N_Component_Association + | N_Iterated_Component_Association | N_Later_Decl_Item | N_Use_Package_Clause | N_Array_Type_Definition @@ -2563,6 +2559,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 +2602,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 +3196,6 @@ package body Errout is E : Error_Msg_Id; Err_Flag : Boolean; - Use_Prefix : Boolean; -- Start of processing for Output_Messages @@ -3155,100 +3256,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/erroutc.adb b/gcc/ada/erroutc.adb index 7a823ce..db1c092 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -327,6 +327,11 @@ package body Erroutc is Write_Location (E.Optr.Ptr); Write_Eol; + Write_Str + (" Insertion_Sloc = "); + Write_Location (E.Insertion_Sloc); + Write_Eol; + w (" Line = ", Int (E.Line)); w (" Col = ", Int (E.Col)); w (" Info = ", E.Info); @@ -683,28 +688,106 @@ package body Erroutc is end if; end Output_Line_Number; - --------------------- - -- Output_Msg_Text -- - --------------------- + ------------------------ + -- Output_Text_Within -- + ------------------------ - procedure Output_Msg_Text (E : Error_Msg_Id) is + procedure Output_Text_Within (Txt : String_Ptr; Line_Length : Nat) is Offs : constant Nat := Column - 1; -- Offset to start of message, used for continuations - Max : Integer; + Ptr : Natural; + + Split : Natural; + -- Position where a new line was inserted in the original message + + Start : Natural; + -- Start of the current line + + Max : Integer := Integer (Line_Length - Column + 1); -- Maximum characters to output on next line - Length : Nat; - -- Maximum total length of lines + Text_Length : constant Natural := Txt'Length; + -- Length of the message + + begin + -- Here we have to split the message up into multiple lines + + Ptr := 1; + loop + -- Make sure we do not have ludicrously small line + + Max := Integer'Max (Max, 20); + + -- If remaining text fits, output it respecting LF and we are done + + if Text_Length - Ptr < Max then + for J in Ptr .. Text_Length loop + if Txt (J) = ASCII.LF then + Write_Eol; + Write_Spaces (Offs); + else + Write_Char (Txt (J)); + end if; + end loop; + + return; + + -- Line does not fit + + else + Start := Ptr; + + -- First scan forward looking for a hard end of line + + for Scan in Ptr .. Ptr + Max - 1 loop + if Txt (Scan) = ASCII.LF then + Split := Scan - 1; + Ptr := Scan + 1; + goto Continue; + end if; + end loop; + + -- Otherwise scan backwards looking for a space + + for Scan in reverse Ptr .. Ptr + Max - 1 loop + if Txt (Scan) = ' ' then + Split := Scan - 1; + Ptr := Scan + 1; + goto Continue; + end if; + end loop; + + -- If we fall through, no space, so split line arbitrarily + + Split := Ptr + Max - 1; + Ptr := Split + 1; + end if; + + <<Continue>> + if Start <= Split then + Write_Line (Txt (Start .. Split)); + Write_Spaces (Offs); + end if; + + Max := Integer (Line_Length - Column + 1); + end loop; + end Output_Text_Within; + + --------------------- + -- Output_Msg_Text -- + --------------------- + + procedure Output_Msg_Text (E : Error_Msg_Id) is E_Msg : Error_Msg_Object renames Errors.Table (E); Text : constant String_Ptr := E_Msg.Text; - Ptr : Natural; - Split : Natural; - Start : Natural; - Tag : constant String := Get_Warning_Tag (E); - Txt : String_Ptr; - Len : Natural; + Tag : constant String := Get_Warning_Tag (E); + Txt : String_Ptr; + + Line_Length : constant Nat := + (if Error_Msg_Line_Length = 0 then Nat'Last + else Error_Msg_Line_Length); begin -- Postfix warning tag to message if needed @@ -788,78 +871,7 @@ package body Erroutc is Txt := new String'(SGR_Error & "error: " & SGR_Reset & Txt.all); end if; - -- Set error message line length and length of message - - if Error_Msg_Line_Length = 0 then - Length := Nat'Last; - else - Length := Error_Msg_Line_Length; - end if; - - Max := Integer (Length - Column + 1); - Len := Txt'Length; - - -- Here we have to split the message up into multiple lines - - Ptr := 1; - loop - -- Make sure we do not have ludicrously small line - - Max := Integer'Max (Max, 20); - - -- If remaining text fits, output it respecting LF and we are done - - if Len - Ptr < Max then - for J in Ptr .. Len loop - if Txt (J) = ASCII.LF then - Write_Eol; - Write_Spaces (Offs); - else - Write_Char (Txt (J)); - end if; - end loop; - - return; - - -- Line does not fit - - else - Start := Ptr; - - -- First scan forward looking for a hard end of line - - for Scan in Ptr .. Ptr + Max - 1 loop - if Txt (Scan) = ASCII.LF then - Split := Scan - 1; - Ptr := Scan + 1; - goto Continue; - end if; - end loop; - - -- Otherwise scan backwards looking for a space - - for Scan in reverse Ptr .. Ptr + Max - 1 loop - if Txt (Scan) = ' ' then - Split := Scan - 1; - Ptr := Scan + 1; - goto Continue; - end if; - end loop; - - -- If we fall through, no space, so split line arbitrarily - - Split := Ptr + Max - 1; - Ptr := Split + 1; - end if; - - <<Continue>> - if Start <= Split then - Write_Line (Txt (Start .. Split)); - Write_Spaces (Offs); - end if; - - Max := Integer (Length - Column + 1); - end loop; + Output_Text_Within (Txt, Line_Length); end Output_Msg_Text; --------------------- @@ -915,15 +927,36 @@ package body Erroutc is -- Start of processing for Prescan_Message begin - -- Nothing to do for continuation line, unless -gnatdF is set + -- Continuation lines need to check only for insertion sequences. + -- Other attributes should be inherited from the main message. + + if Msg (Msg'First) = '\' then + Has_Insertion_Line := False; + + J := Msg'First; + + -- If we have a quote, don't look at following character + + while J <= Msg'Last loop + if Msg (J) = ''' then + J := J + 2; + + -- Insertion line (# insertion) + + elsif Msg (J) = '#' then + Has_Insertion_Line := True; + J := J + 1; + else + J := J + 1; + end if; + end loop; - if not Debug_Flag_FF and then Msg (Msg'First) = '\' then return; -- Some global variables are not set for continuation messages, as they -- only make sense for the initial message. - elsif Msg (Msg'First) /= '\' then + else -- Set initial values of globals (may be changed during scan) diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 5d48d5b..0a52af5 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -519,6 +519,10 @@ package Erroutc is -- splits the line generating multiple lines of output, and in this case -- the last line has no terminating end of line character. + procedure Output_Text_Within (Txt : String_Ptr; Line_Length : Nat); + -- Output the text in Txt, splitting it into lines of at most the size of + -- Line_Length. + procedure Prescan_Message (Msg : String); -- Scans message text and sets the following variables: -- @@ -551,8 +555,7 @@ package Erroutc is -- test these values before doing the full error scan. -- -- Note that the call has no effect for continuation messages (those whose - -- first character is '\'), and all variables are left unchanged, unless - -- -gnatdF is set. + -- first character is '\') except for the Has_Insertion_Line setting. procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr); -- All error messages whose location is in the range From .. To (not diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index aa6079d..c94a6b9 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5946,12 +5946,7 @@ package body Exp_Aggr is then return; - elsif Present (Component_Associations (N)) - and then Nkind (First (Component_Associations (N))) = - N_Iterated_Component_Association - and then - Present (Iterator_Specification (First (Component_Associations (N)))) - then + elsif Is_Two_Pass_Aggregate (N) then Two_Pass_Aggregate_Expansion (N); return; @@ -6637,12 +6632,11 @@ package body Exp_Aggr is Comp : Node_Id; Init_Stat : Node_Id; - Siz : Int; -- The following are used when the size of the aggregate is not -- static and requires a dynamic evaluation. Siz_Decl : Node_Id; - Siz_Exp : Node_Id := Empty; + Siz_Exp : Node_Id; -- These variables are used to determine the smallest and largest -- choice values. Choice_Lo and Choice_Hi are passed to the New_Indexed @@ -6653,14 +6647,18 @@ package body Exp_Aggr is Is_Indexed_Aggregate : Boolean := False; - function Aggregate_Size return Int; + function Aggregate_Size return Node_Id; -- Compute number of entries in aggregate, including choices -- that cover a range or subtype, as well as iterated constructs. - -- Return -1 if the size is not known statically, in which case - -- allocate a default size for the aggregate, or build an expression - -- to estimate the size dynamically. + -- The size of the aggregate can either be a statically known in which + -- case it is returned as an integer literal, or it can be a dynamic + -- expression in which case an empty node is returned. + -- + -- It is not possible to determine the size for all case. When that + -- happens this function returns an empty node. In that case we will + -- later just allocate a default size for the aggregate. - function Build_Siz_Exp (Comp : Node_Id) return Int; + function Build_Siz_Exp (Comp : Node_Id) return Node_Id; -- When the aggregate contains a single Iterated_Component_Association -- or Element_Association with non-static bounds, build an expression -- to be used as the allocated size of the container. This may be an @@ -6683,167 +6681,102 @@ package body Exp_Aggr is -- that calls the appropriate operation Insert_Op to add the value of -- Expr to each container element with an index in the range. + function To_Int (Expr : N_Subexpr_Id) return Int; + -- Return the Int value corresponding to the bound Expr + -------------------- -- Aggregate_Size -- -------------------- - function Aggregate_Size return Int is - Comp : Node_Id; - Choice : Node_Id; - Lo, Hi : Node_Id; - Siz : Int; - - procedure Add_Range_Size; - -- Compute number of components specified by a component association - -- given by a range or subtype name. - - -------------------- - -- Add_Range_Size -- - -------------------- - - procedure Add_Range_Size is - function To_Int (Expr : N_Subexpr_Id) return Int; - -- Return the Int value corresponding to the bound Expr - - ------------ - -- To_Int -- - ------------ - - function To_Int (Expr : N_Subexpr_Id) return Int is - begin - -- The bounds of the discrete range are integers or enumeration - -- literals - return UI_To_Int - ((if Nkind (Expr) = N_Integer_Literal then - Intval (Expr) - else - Enumeration_Pos (Expr))); - end To_Int; - - -- Local variables - - Range_Int_Lo : constant Int := To_Int (Lo); - Range_Int_Hi : constant Int := To_Int (Hi); - - begin - Siz := Siz + Range_Int_Hi - Range_Int_Lo + 1; - - if No (Choice_Lo) or else Range_Int_Lo < To_Int (Choice_Lo) then - Choice_Lo := Lo; - end if; - - if No (Choice_Hi) or else Range_Int_Hi > To_Int (Choice_Hi) then - Choice_Hi := Hi; - end if; - end Add_Range_Size; + function Aggregate_Size return Node_Id is + Comp : Node_Id; + Comp_Siz_Exp : Node_Id; + Siz_Exp : Node_Id; -- Start of processing for Aggregate_Size begin -- Aggregate is either all positional or all named - Siz := List_Length (Expressions (N)); + Siz_Exp := Make_Integer_Literal (Loc, List_Length (Expressions (N))); + Set_Is_Static_Expression (Siz_Exp); if Present (Component_Associations (N)) then Comp := First (Component_Associations (N)); - -- If one or more of the associations is one of the iterated - -- forms, and is either an association with nonstatic bounds - -- or is an iterator over an iterable object where the size - -- cannot be derived, then treat the whole container aggregate as - -- having a nonstatic number of elements. - - declare - Has_Nonstatic_Length : Boolean := False; - - begin - while Present (Comp) loop - if Nkind (Comp) in N_Iterated_Component_Association | - N_Iterated_Element_Association - and then Build_Siz_Exp (Comp) = -1 - then - Has_Nonstatic_Length := True; - end if; - - Next (Comp); - end loop; - - if Has_Nonstatic_Length then - return -1; - end if; - end; - - -- Otherwise, the aggregate must have associations where all - -- choices and bounds are statically known, and we compute - -- the number of elements statically by adding up the number - -- of elements in each association. - - Comp := First (Component_Associations (N)); - while Present (Comp) loop - if Present (Choice_List (Comp)) then - Choice := First (Choice_List (Comp)); - - while Present (Choice) loop - Analyze (Choice); + Comp_Siz_Exp := Build_Siz_Exp (Comp); - if Nkind (Choice) = N_Range then - Lo := Low_Bound (Choice); - Hi := High_Bound (Choice); - Add_Range_Size; + if No (Comp_Siz_Exp) then - -- Choice is subtype_mark; add range based on its bounds + -- If the size of the component cannot be determined then + -- we cannot continue with the dynamic evalution and we + -- should use the default value instead. - elsif Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice)) - then - Lo := Type_Low_Bound (Entity (Choice)); - Hi := Type_High_Bound (Entity (Choice)); - Add_Range_Size; - - Rewrite (Choice, - Make_Range (Loc, - New_Copy_Tree (Lo), - New_Copy_Tree (Hi))); - - -- Choice is a single discrete value - - elsif Is_Discrete_Type (Etype (Choice)) then - Lo := Choice; - Hi := Choice; - Add_Range_Size; - - -- Choice is a single value of some nondiscrete type - - else - -- Single choice (syntax excludes a subtype - -- indication). - - Siz := Siz + 1; - end if; - - Next (Choice); - end loop; + return Empty; + else + if Is_Static_Expression (Siz_Exp) + and then Is_Static_Expression (Comp_Siz_Exp) + then + -- Create a simpler version of the expression - elsif Nkind (Comp) = N_Iterated_Component_Association then + Siz_Exp := Make_Integer_Literal (Loc, + To_Int (Siz_Exp) + To_Int (Comp_Siz_Exp)); - Siz := Siz + Build_Siz_Exp (Comp); + Set_Is_Static_Expression (Siz_Exp); + else + Siz_Exp := Make_Op_Add (Sloc (Comp), + Left_Opnd => Siz_Exp, + Right_Opnd => Comp_Siz_Exp); + end if; end if; + Next (Comp); end loop; end if; - return Siz; + return Siz_Exp; end Aggregate_Size; ------------------- -- Build_Siz_Exp -- ------------------- - function Build_Siz_Exp (Comp : Node_Id) return Int is + function Build_Siz_Exp (Comp : Node_Id) return Node_Id is Lo, Hi : Node_Id; - Temp_Siz_Exp : Node_Id; It : Node_Id; + Siz_Exp : Node_Id := Empty; + Choice : Node_Id; + Temp_Siz_Exp : Node_Id; + Siz : Int; + + procedure Update_Choices (Lo : Node_Id; Hi : Node_Id); + -- Update the Choice_Lo and Choice_Hi variables with the smallest + -- and largest possible node values. + + procedure Update_Choices (Lo : Node_Id; Hi : Node_Id) is + -- Local variables + + Range_Int_Lo : constant Int := To_Int (Lo); + Range_Int_Hi : constant Int := To_Int (Hi); + + begin + if No (Choice_Lo) + or else (Is_Static_Expression (Choice_Lo) + and then Range_Int_Lo < To_Int (Choice_Lo)) + then + Choice_Lo := Lo; + end if; + + if No (Choice_Hi) + or else (Is_Static_Expression (Choice_Hi) + and then Range_Int_Hi > To_Int (Choice_Hi)) + then + Choice_Hi := Hi; + end if; + end Update_Choices; + + -- Start of processing for Build_Siz_Exp begin if Nkind (Comp) = N_Range then @@ -6857,59 +6790,27 @@ package body Exp_Aggr is if Is_Static_Expression (Lo) and then Is_Static_Expression (Hi) then - if Nkind (Lo) = N_Integer_Literal then - Siz := UI_To_Int (Intval (Hi)) - UI_To_Int (Intval (Lo)) + 1; - else - Siz := UI_To_Int (Enumeration_Pos (Hi)) - - UI_To_Int (Enumeration_Pos (Lo)) + 1; - end if; + Update_Choices (Lo, Hi); - -- Include the static value in the computation of the aggregate - -- length in Siz_Exp. This will only end up being used if there - -- are one or more associations that have nonstatic ranges. - - if Present (Siz_Exp) then - Siz_Exp := Make_Op_Add (Sloc (Comp), - Left_Opnd => Siz_Exp, - Right_Opnd => Make_Integer_Literal (Loc, Siz)); - else - Siz_Exp := Make_Integer_Literal (Loc, Siz); - end if; + Siz := To_Int (Hi) - To_Int (Lo) + 1; + Siz_Exp := Make_Integer_Literal (Loc, Siz); + Set_Is_Static_Expression (Siz_Exp); - return Siz; + return Siz_Exp; + else + -- Capture the nonstatic bounds, for later use in passing on + -- the call to New_Indexed. - -- The possibility of having multiple associations with nonstatic - -- ranges (plus static ranges) means that in general we have to - -- accumulate a sum of the various sizes. + Choice_Lo := Lo; + Choice_Hi := Hi; - else - Temp_Siz_Exp := - Make_Op_Add (Sloc (Comp), + return Make_Op_Add (Sloc (Comp), Left_Opnd => Make_Op_Subtract (Sloc (Comp), Left_Opnd => New_Copy_Tree (Hi), Right_Opnd => New_Copy_Tree (Lo)), Right_Opnd => Make_Integer_Literal (Loc, 1)); - - -- Capture the nonstatic bounds, for later use in passing on - -- the call to New_Indexed. - - Choice_Lo := Lo; - Choice_Hi := Hi; - - -- Include this nonstatic length in the total length being - -- accumulated in Siz_Exp. - - if Present (Siz_Exp) then - Siz_Exp := Make_Op_Add (Sloc (Comp), - Left_Opnd => Siz_Exp, - Right_Opnd => Temp_Siz_Exp); - else - Siz_Exp := Temp_Siz_Exp; - end if; - - return -1; end if; elsif Nkind (Comp) = N_Iterated_Component_Association then @@ -6921,29 +6822,128 @@ package body Exp_Aggr is It := Name (Iterator_Specification (Comp)); Preanalyze (It); - -- Handle the simplest cases for now where It denotes a - -- top-level one-dimensional array objects". + -- Handle the simplest cases for now where It denotes an array + -- object. if Nkind (It) in N_Identifier and then Ekind (Etype (It)) = E_Array_Subtype - and then No (Next_Index (First_Index (Etype (It)))) then - return Build_Siz_Exp (First_Index (Etype (It))); + declare + Idx_N : Node_Id := First_Index (Etype (It)); + Siz_Exp : Node_Id := Empty; + begin + while Present (Idx_N) loop + Temp_Siz_Exp := Build_Siz_Exp (Idx_N); + + pragma Assert (Present (Temp_Siz_Exp)); + + if Present (Siz_Exp) then + if Is_Static_Expression (Siz_Exp) + and then Is_Static_Expression (Temp_Siz_Exp) + then + + -- Create a simpler version of the expression + + Siz_Exp := Make_Integer_Literal (Loc, + To_Int (Siz_Exp) * + To_Int (Temp_Siz_Exp)); + + Set_Is_Static_Expression (Siz_Exp); + else + Siz_Exp := Make_Op_Multiply (Sloc (Comp), + Left_Opnd => Siz_Exp, + Right_Opnd => Temp_Siz_Exp); + end if; + else + Siz_Exp := Temp_Siz_Exp; + end if; + + Next_Index (Idx_N); + end loop; + + return Siz_Exp; + end; end if; - return -1; + return Empty; else return Build_Siz_Exp (First (Discrete_Choices (Comp))); end if; + + elsif Nkind (Comp) = N_Component_Association then + Choice := First (Choices (Comp)); + + while Present (Choice) loop + Analyze (Choice); + + if Nkind (Choice) = N_Range then + + Temp_Siz_Exp := Build_Siz_Exp (Choice); + + -- Choice is subtype_mark; add range based on its bounds + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + Lo := Type_Low_Bound (Entity (Choice)); + Hi := Type_High_Bound (Entity (Choice)); + + Rewrite (Choice, + Make_Range (Loc, + New_Copy_Tree (Lo), + New_Copy_Tree (Hi))); + + Temp_Siz_Exp := Build_Siz_Exp (Choice); + + -- Choice is a single discrete value + + elsif Is_Discrete_Type (Etype (Choice)) then + Update_Choices (Choice, Choice); + + Temp_Siz_Exp := Make_Integer_Literal (Loc, 1); + Set_Is_Static_Expression (Temp_Siz_Exp); + + -- Choice is a single value of some nondiscrete type + + else + Temp_Siz_Exp := Make_Integer_Literal (Loc, 1); + Set_Is_Static_Expression (Temp_Siz_Exp); + end if; + + if Present (Siz_Exp) then + + if Is_Static_Expression (Siz_Exp) + and then Is_Static_Expression (Temp_Siz_Exp) + then + -- Create a simpler version of the expression + + Siz_Exp := Make_Integer_Literal + (Loc, To_Int (Siz_Exp) + To_Int (Temp_Siz_Exp)); + + Set_Is_Static_Expression (Siz_Exp); + else + Siz_Exp := Make_Op_Add + (Sloc (Comp), + Left_Opnd => Siz_Exp, + Right_Opnd => Temp_Siz_Exp); + end if; + else + Siz_Exp := Temp_Siz_Exp; + end if; + + Next (Choice); + end loop; + + return Siz_Exp; elsif Nkind (Comp) = N_Iterated_Element_Association then - return -1; + return Empty; -- ??? Need to create code for a loop and add to generated code, -- as is done for array aggregates with iterated element -- associations, instead of using Append operations. else - return -1; + return Empty; end if; end Build_Siz_Exp; @@ -7117,6 +7117,19 @@ package body Exp_Aggr is Statements => Stats); end Expand_Range_Component; + ------------ + -- To_Int -- + ------------ + + function To_Int (Expr : N_Subexpr_Id) return Int is + begin + -- The bounds of the discrete range are integers or enumeration + -- literals + return UI_To_Int ((if Nkind (Expr) = N_Integer_Literal + then Intval (Expr) + else Enumeration_Pos (Expr))); + end To_Int; + -- Start of processing for Expand_Container_Aggregate begin @@ -7126,22 +7139,22 @@ package body Exp_Aggr is -- Determine whether this is an indexed aggregate (see RM 4.3.5(25/5)) - Is_Indexed_Aggregate - := Sem_Aggr.Is_Indexed_Aggregate - (N, Add_Unnamed_Subp, New_Indexed_Subp); + Is_Indexed_Aggregate := + Sem_Aggr.Is_Indexed_Aggregate + (N, Add_Unnamed_Subp, New_Indexed_Subp); -- The constructor for bounded containers is a function with -- a parameter that sets the size of the container. If the -- size cannot be determined statically we use a default value -- or a dynamic expression. - Siz := Aggregate_Size; + Siz_Exp := Aggregate_Size; declare Count_Type : Entity_Id := Standard_Natural; Default : Node_Id := Empty; - Empty_First_Formal : constant Entity_Id - := First_Formal (Entity (Empty_Subp)); + Empty_First_Formal : constant Entity_Id := + First_Formal (Entity (Empty_Subp)); Param_List : List_Id; begin @@ -7160,31 +7173,24 @@ package body Exp_Aggr is -- expression if iterated component associations may be involved, -- and the default otherwise. - if Siz = -1 then - if No (Siz_Exp) - and Present (Default) - then - Siz := UI_To_Int (Intval (Default)); - Siz_Exp := Make_Integer_Literal (Loc, Siz); - - elsif Present (Siz_Exp) then - Siz_Exp := Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (Count_Type, Loc), - Expression => Siz_Exp); + if Present (Siz_Exp) then + Siz_Exp := Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Count_Type, Loc), + Expression => Siz_Exp); - -- If the length isn't known and there's not a default, then use - -- zero for the initial container length. + elsif Present (Default) then + Siz_Exp := Make_Integer_Literal (Loc, + UI_To_Int (Intval (Default))); - else - Siz_Exp := Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (Count_Type, Loc), - Expression => Make_Integer_Literal (Loc, 0)); - end if; + -- If the length isn't known and there's not a default, then use + -- zero for the initial container length. else - Siz_Exp := Make_Integer_Literal (Loc, Siz); + Siz_Exp := Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Count_Type, Loc), + Expression => Make_Integer_Literal (Loc, 0)); end if; Siz_Decl := Make_Object_Declaration (Loc, @@ -7276,9 +7282,9 @@ package body Exp_Aggr is Error_Msg_Warn := SPARK_Mode /= On; Error_Msg_N ("!empty aggregate returned by the empty function of a container" - & " aggregate<<<", Parent (N)); + & " aggregate<<", Parent (N)); Error_Msg_N - ("\this will result in infinite recursion??", Parent (N)); + ("\this will result in infinite recursion<<", Parent (N)); end if; --------------------------- @@ -7636,8 +7642,8 @@ package body Exp_Aggr is declare -- recursively get name for prefix - LHS_Prefix : constant Node_Id - := Make_Delta_Choice_LHS (Prefix (Choice), Deep_Choice); + LHS_Prefix : constant Node_Id := + Make_Delta_Choice_LHS (Prefix (Choice), Deep_Choice); begin if Nkind (Choice) = N_Indexed_Component then return Make_Indexed_Component (Sloc (Choice), @@ -8872,6 +8878,21 @@ package body Exp_Aggr is and then C in Uint_1 | Uint_2 | Uint_4; -- False if No_Uint end Is_Two_Dim_Packed_Array; + --------------------------- + -- Is_Two_Pass_Aggregate -- + --------------------------- + + function Is_Two_Pass_Aggregate (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Aggregate + and then Present (Component_Associations (N)) + and then Nkind (First (Component_Associations (N))) = + N_Iterated_Component_Association + and then + Present + (Iterator_Specification (First (Component_Associations (N)))); + end Is_Two_Pass_Aggregate; + -------------------- -- Late_Expansion -- -------------------- diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads index 17fa38b..aa79616 100644 --- a/gcc/ada/exp_aggr.ads +++ b/gcc/ada/exp_aggr.ads @@ -58,6 +58,10 @@ package Exp_Aggr is -- Returns True if N is a conditional expression whose Expansion_Delayed -- flag is set (see sinfo for meaning of flag). + function Is_Two_Pass_Aggregate (N : Node_Id) return Boolean; + -- Return True if N is an aggregate that is to be expanded in two passes. + -- This is the case if it consists only of iterated associations. + function Static_Array_Aggregate (N : Node_Id) return Boolean; -- N is an array aggregate that may have a component association with -- an others clause and a range. If bounds are static and the expressions diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 6475308..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 @@ -6006,6 +6073,7 @@ package body Exp_Attr is when Attribute_Put_Image => Put_Image : declare use Exp_Put_Image; U_Type : constant Entity_Id := Underlying_Type (Entity (Pref)); + C_Type : Entity_Id; Pname : Entity_Id; Decl : Node_Id; @@ -6031,6 +6099,21 @@ package body Exp_Attr is end if; if No (Pname) then + if Is_String_Type (U_Type) then + declare + R : constant Entity_Id := Root_Type (U_Type); + + begin + if Is_Private_Type (R) then + C_Type := Component_Type (Full_View (R)); + else + C_Type := Component_Type (R); + end if; + + C_Type := Root_Type (Underlying_Type (C_Type)); + end; + end if; + -- If Put_Image is disabled, call the "unknown" version if not Put_Image_Enabled (U_Type) then @@ -6046,7 +6129,17 @@ package body Exp_Attr is Analyze (N); return; - elsif Is_Standard_String_Type (U_Type) then + -- String type objects, including custom string types, and + -- excluding C arrays. + + elsif Is_String_Type (U_Type) + and then C_Type in Standard_Character + | Standard_Wide_Character + | Standard_Wide_Wide_Character + and then (not RTU_Loaded (Interfaces_C) + or else Enclosing_Lib_Unit_Entity (U_Type) + /= RTU_Entity (Interfaces_C)) + then Rewrite (N, Build_String_Put_Image_Call (N)); Analyze (N); return; diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 958f429..99a1694 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -768,6 +768,7 @@ package body Exp_Ch2 is New_Occurrence_Of (Sink_Entity, Loc)))); Actions : constant List_Id := New_List; + U_Type : constant Entity_Id := Underlying_Type (Etype (N)); Elem_Typ : Entity_Id; Str_Elem : Node_Id; @@ -810,6 +811,19 @@ package body Exp_Ch2 is Next (Str_Elem); end loop; + -- Add a type conversion to the result object declaration of custom + -- string types. + + if not Is_Standard_String_Type (U_Type) + and then (not RTU_Loaded (Interfaces_C) + or else Enclosing_Lib_Unit_Entity (U_Type) + /= RTU_Entity (Interfaces_C)) + then + Set_Expression (Result_Decl, + Convert_To (Etype (N), + Relocate_Node (Expression (Result_Decl)))); + end if; + Append_To (Actions, Result_Decl); return Make_Expression_With_Actions (Loc, diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index bf04ea9..139fce8 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5429,17 +5429,22 @@ package body Exp_Ch3 is if not Is_Bit_Packed_Array (Typ) then if No (Init_Proc (Base)) then - -- If this is an anonymous array created for a declaration with - -- an initial value, its init_proc will never be called. The + -- If this is an anonymous array built for an object declaration + -- with an initial value, its Init_Proc will never be called. The -- initial value itself may have been expanded into assignments, - -- in which case the object declaration is carries the - -- No_Initialization flag. + -- in which case the declaration has the No_Initialization flag. + -- The exception is when the initial value is a 2-pass aggregate, + -- because the special expansion used for it creates a temporary + -- that needs a fully-fledged initialization. if Is_Itype (Base) and then Nkind (Associated_Node_For_Itype (Base)) = N_Object_Declaration and then - (Present (Expression (Associated_Node_For_Itype (Base))) + ((Present (Expression (Associated_Node_For_Itype (Base))) + and then not + Is_Two_Pass_Aggregate + (Expression (Associated_Node_For_Itype (Base)))) or else No_Initialization (Associated_Node_For_Itype (Base))) then null; @@ -7658,11 +7663,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 +8352,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")); @@ -10248,7 +10249,8 @@ package body Exp_Ch3 is if Nkind (Expr) = N_Unchecked_Type_Conversion and then Is_Scalar_Type (Under_Typ) then - Set_No_Truncation (Expr); + Set_Kill_Range_Check (Expr); + Set_No_Truncation (Expr); end if; return Expr; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 106305f..9024c1a 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2799,9 +2799,9 @@ package body Exp_Ch4 is if Is_Constrained (Opnd_Typ) then declare - Low_Bound : constant Node_Id - := Type_Low_Bound - (Underlying_Type (Etype (First_Index (Opnd_Typ)))); + Low_Bound : constant Node_Id := + Type_Low_Bound + (Underlying_Type (Etype (First_Index (Opnd_Typ)))); begin if Compile_Time_Known_Value (Low_Bound) then @@ -3013,11 +3013,11 @@ package body Exp_Ch4 is else declare Known_Bound : constant Node_Id := Get_Known_Bound (J + 1); - Comparison : constant Compare_Result - := Compile_Time_Compare - (Opnd_Low_Bound (J), - Known_Bound, - Assume_Valid => True); + Comparison : constant Compare_Result := + Compile_Time_Compare + (Opnd_Low_Bound (J), + Known_Bound, + Assume_Valid => True); begin if Comparison = EQ then diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 7ff54cb..8cad734 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2969,9 +2969,9 @@ package body Exp_Ch5 is then Tagged_Case : declare L : List_Id := No_List; - Expand_Ctrl_Actions : constant Boolean - := not No_Ctrl_Actions (N) - and then not No_Finalize_Actions (N); + Expand_Ctrl_Actions : constant Boolean := + not No_Ctrl_Actions (N) + and then not No_Finalize_Actions (N); begin -- In the controlled case, we ensure that function calls are @@ -3791,8 +3791,8 @@ package body Exp_Ch5 is pragma Assert (No (Expressions (Pattern))); declare - Component_Assoc : Node_Id - := First (Component_Associations (Pattern)); + Component_Assoc : Node_Id := + First (Component_Associations (Pattern)); Choice : Node_Id; function Subobject return Node_Id is diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 24b7547..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 @@ -3879,7 +3875,7 @@ package body Exp_Ch6 is Formal : Entity_Id; begin - Actual := First (Parameter_Associations (Call_Node)); + Actual := First_Actual (Call_Node); Formal := First_Formal (Subp); while Present (Actual) and then Present (Formal) @@ -3891,7 +3887,7 @@ package body Exp_Ch6 is return True; end if; - Next (Actual); + Next_Actual (Actual); Next_Formal (Formal); end loop; end; @@ -5262,7 +5258,9 @@ package body Exp_Ch6 is -- function call is transformed into a reference to the result that has -- been built either on the primary or the secondary stack. - if Needs_Finalization (Etype (Subp)) then + if Nkind (Call_Node) = N_Function_Call + and then Needs_Finalization (Etype (Call_Node)) + then if not Is_Build_In_Place_Function_Call (Call_Node) and then (No (First_Formal (Subp)) @@ -5270,7 +5268,7 @@ package body Exp_Ch6 is not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) then Expand_Ctrl_Function_Call - (Call_Node, Needs_Secondary_Stack (Etype (Subp))); + (Call_Node, Needs_Secondary_Stack (Etype (Call_Node))); -- Build-in-place function calls which appear in anonymous contexts -- need a transient scope to ensure the proper finalization of the @@ -5292,7 +5290,7 @@ package body Exp_Ch6 is Is_Build_In_Place_Function_Call (Parent (Call_Node))) then Establish_Transient_Scope - (Call_Node, Needs_Secondary_Stack (Etype (Subp))); + (Call_Node, Needs_Secondary_Stack (Etype (Call_Node))); end if; end if; end Expand_Call_Helper; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 939a8e2..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 @@ -1344,6 +1345,9 @@ package body Exp_Ch9 is Rec_Ent : constant Entity_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (Ctyp), 'V')); + Alist : List_Id; + Asp_Copy : Node_Id; + Aspect : Node_Id; Disc : Entity_Id; Dlist : List_Id; New_Disc : Entity_Id; @@ -1394,6 +1398,37 @@ package body Exp_Ch9 is Dlist := No_List; end if; + -- Propagate the aspect First_Controlling_Parameter to the corresponding + -- record to reuse the tagged types machinery. This is not needed if + -- the concurrent type does not implement interface types, as the + -- corresponding record will not be a tagged type in such case. + + Alist := No_List; + + if Present (Parent (Ctyp)) + and then Present (Interface_List (Parent (Ctyp))) + and then Present (Aspect_Specifications (N)) + then + Aspect := First (Aspect_Specifications (N)); + while Present (Aspect) loop + if Chars (Identifier (Aspect)) + = Name_First_Controlling_Parameter + then + Alist := New_List; + Asp_Copy := New_Copy_Tree (Aspect); + + -- Force its analysis in the corresponding record to add + -- the pragma. + + Set_Analyzed (Asp_Copy, False); + Append_To (Alist, Asp_Copy); + exit; + end if; + + Next (Aspect); + end loop; + end if; + -- Now we can construct the record type declaration. Note that this -- record is "limited tagged". It is "limited" to reflect the underlying -- limitedness of the task or protected object that it represents, and @@ -1405,6 +1440,7 @@ package body Exp_Ch9 is return Make_Full_Type_Declaration (Loc, Defining_Identifier => Rec_Ent, + Aspect_Specifications => Alist, Discriminant_Specifications => Dlist, Type_Definition => Make_Record_Definition (Loc, @@ -9257,6 +9293,25 @@ package body Exp_Ch9 is Analyze (Rec_Decl, Suppress => All_Checks); + -- Analyze aspects of the corresponding record type. They may have been + -- propagated to it and its analysis is required to add the pragma (see + -- propagation of aspect First_Controlling_Parameter in the subprogram + -- Build_Corresponding_Record). + + if Has_Aspects (Rec_Decl) then + Analyze_Aspect_Specifications (Rec_Decl, Rec_Id); + + -- Handle aspects that may have been implicitly inherited and must be + -- explicitly propagated to the corresponding record type. This applies + -- specifically when the First_Controlling_Parameter aspect has been + -- implicitly inherited from an implemented interface. + + elsif Present (Interface_List (Parent (Prot_Typ))) + and then Has_First_Controlling_Parameter_Aspect (Prot_Typ) + then + Set_Has_First_Controlling_Parameter_Aspect (Rec_Id); + end if; + -- Ada 2005 (AI-345): Construct the primitive entry wrappers before -- the corresponding record is frozen. If any wrappers are generated, -- Current_Node is updated accordingly. @@ -12162,6 +12217,25 @@ package body Exp_Ch9 is Analyze (Rec_Decl); + -- Analyze aspects of the corresponding record type. They may have been + -- propagated to it and its analysis is required to add the pragma (see + -- propagation of aspect First_Controlling_Parameter in the subprogram + -- Build_Corresponding_Record). + + if Has_Aspects (Rec_Decl) then + Analyze_Aspect_Specifications (Rec_Decl, Rec_Ent); + + -- Handle aspects that may have been implicitly inherited and must be + -- explicitly propagated to the corresponding record type. This applies + -- specifically when the First_Controlling_Parameter aspect has been + -- implicitly inherited from an implemented interface. + + elsif Present (Interface_List (Parent (Tasktyp))) + and then Has_First_Controlling_Parameter_Aspect (Tasktyp) + then + Set_Has_First_Controlling_Parameter_Aspect (Rec_Ent); + end if; + -- Create the declaration of the task body procedure Proc_Spec := Build_Task_Proc_Specification (Tasktyp); @@ -14795,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_dbug.adb b/gcc/ada/exp_dbug.adb index 64e3871..9ab2203 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -1061,8 +1061,8 @@ package body Exp_Dbug is if Ancestor_Typ /= Typ then declare Len : constant Natural := Name_Len; - Save_Str : constant String (1 .. Name_Len) - := Name_Buffer (1 .. Name_Len); + Save_Str : constant String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); begin Get_External_Name (Ancestor_Typ); diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index e5d84cc..ef2a3a3 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; @@ -1435,11 +1431,11 @@ package body Exp_Imgv is procedure Expand_Valid_Value_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); + Args : constant List_Id := Expressions (N); Btyp : constant Entity_Id := Base_Type (Entity (Prefix (N))); Rtyp : constant Entity_Id := Root_Type (Btyp); pragma Assert (Is_Enumeration_Type (Rtyp)); - Args : constant List_Id := Expressions (N); Func : RE_Id; Ttyp : Entity_Id; @@ -1447,7 +1443,7 @@ package body Exp_Imgv is -- Generate: -- Valid_Value_Enumeration_NN - -- (typS, typN'Address, typH'Unrestricted_Access, Num, X) + -- (typS, typN'Address, typH'Unrestricted_Access, Num, Is_Wide, X) Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); @@ -1459,6 +1455,10 @@ package body Exp_Imgv is Func := RE_Valid_Value_Enumeration_32; end if; + -- The Valid_[Wide_]Wide_Value attribute does not exist + + Prepend_To (Args, New_Occurrence_Of (Standard_False, Loc)); + Prepend_To (Args, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Rtyp, Loc), @@ -1550,7 +1550,7 @@ package body Exp_Imgv is -- Enum'Val -- (Value_Enumeration_NN - -- (typS, typN'Address, typH'Unrestricted_Access, Num, X)) + -- (typS, typN'Address, typH'Unrestricted_Access, Num, Is_Wide, X)) -- where typS, typN and typH are the Lit_Strings, Lit_Indexes and Lit_Hash -- entities from T's root type entity, and Num is Enum'Pos (Enum'Last). @@ -1562,14 +1562,15 @@ package body Exp_Imgv is procedure Expand_Value_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); + Args : constant List_Id := Expressions (N); Btyp : constant Entity_Id := Etype (N); pragma Assert (Is_Base_Type (Btyp)); pragma Assert (Btyp = Base_Type (Entity (Prefix (N)))); Rtyp : constant Entity_Id := Root_Type (Btyp); - Args : constant List_Id := Expressions (N); - Ttyp : Entity_Id; - Vid : RE_Id; + Is_Wide : Boolean; + Ttyp : Entity_Id; + Vid : RE_Id; begin -- Fall through for all cases except user-defined enumeration type @@ -1721,9 +1722,9 @@ package body Exp_Imgv is -- Normal case where we have enumeration tables, build - -- T'Val - -- (Value_Enumeration_NN - -- (typS, typN'Address, typH'Unrestricted_Access, Num, X)) + -- T'Val + -- (Value_Enumeration_NN + -- (typS, typN'Address, typH'Unrestricted_Access, Num, Is_Wide, X)) else Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); @@ -1736,6 +1737,25 @@ package body Exp_Imgv is Vid := RE_Value_Enumeration_32; end if; + if Nkind (First (Args)) = N_Function_Call + and then Is_Entity_Name (Name (First (Args))) + then + declare + E : constant Entity_Id := Entity (Name (First (Args))); + + begin + Is_Wide := Is_RTE (E, RE_Wide_String_To_String) + or else + Is_RTE (E, RE_Wide_Wide_String_To_String); + end; + + else + Is_Wide := False; + end if; + + Prepend_To (Args, + New_Occurrence_Of (Boolean_Literals (Is_Wide), Loc)); + Prepend_To (Args, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Rtyp, Loc), @@ -2501,18 +2521,43 @@ package body Exp_Imgv is Attr_Name : Name_Id; Str_Typ : Entity_Id) is + P : Node_Id; Ptyp : Entity_Id; begin - Ptyp := Etype (Pref); + P := Pref; + Ptyp := Etype (P); + + -- If the type of the prefix is universal integer, which is a very large + -- type, try to compute a narrower type. This may happen when the prefix + -- itself is an attribute returning universal integer or a named number. + + if Ptyp = Universal_Integer then + if Nkind (P) in N_Type_Conversion | N_Unchecked_Type_Conversion then + P := Expression (P); + Ptyp := Etype (P); + + elsif Nkind (P) = N_Integer_Literal then + declare + Val : constant Uint := Intval (P); + Neg : constant Boolean := Val < Uint_0; + Bits : constant Nat := Num_Bits (Val) + Boolean'Pos (Neg); + + begin + if Bits <= System_Max_Integer_Size then + Ptyp := Integer_Type_For (UI_From_Int (Bits), not Neg); + end if; + end; + end if; + end if; -- If the prefix is a component that depends on a discriminant, then -- create an actual subtype for it. - if Nkind (Pref) = N_Selected_Component then + if Nkind (P) = N_Selected_Component then declare Decl : constant Node_Id := - Build_Actual_Subtype_Of_Component (Ptyp, Pref); + Build_Actual_Subtype_Of_Component (Ptyp, P); begin if Present (Decl) then Insert_Action (N, Decl); @@ -2525,7 +2570,7 @@ package body Exp_Imgv is Make_Attribute_Reference (Sloc (N), Prefix => New_Occurrence_Of (Ptyp, Sloc (N)), Attribute_Name => Attr_Name, - Expressions => New_List (Unchecked_Convert_To (Ptyp, Pref)))); + Expressions => New_List (Unchecked_Convert_To (Ptyp, P)))); Analyze_And_Resolve (N, Str_Typ); end Rewrite_Object_Image; 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_prag.adb b/gcc/ada/exp_prag.adb index 2c054d1..6c328ef 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -2519,11 +2519,11 @@ package body Exp_Prag is procedure Expand_Pragma_Inspection_Point (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - A : List_Id; - Assoc : Node_Id; - E : Entity_Id; - Rip : Boolean; - S : Entity_Id; + A : List_Id; + Assoc : Node_Id; + Faulty_Arg : Node_Id := Empty; + E : Entity_Id; + S : Entity_Id; begin if No (Pragma_Argument_Associations (N)) then @@ -2556,7 +2556,6 @@ package body Exp_Prag is -- Process the arguments of the pragma - Rip := False; Assoc := First (Pragma_Argument_Associations (N)); while Present (Assoc) loop -- The back end may need to take the address of the object @@ -2574,7 +2573,7 @@ package body Exp_Prag is ("??inspection point references unfrozen object &", Assoc, Entity (Expression (Assoc))); - Rip := True; + Faulty_Arg := Assoc; end if; Next (Assoc); @@ -2582,8 +2581,10 @@ package body Exp_Prag is -- When the above requirement isn't met, turn the pragma into a no-op - if Rip then - Error_Msg_N ("\pragma will be ignored", N); + if Present (Faulty_Arg) then + Error_Msg_Sloc := Sloc (Faulty_Arg); + Error_Msg_N ("\pragma Inspection_Point # will be ignored", + Faulty_Arg); -- We can't just remove the pragma from the tree as it might be -- iterated over by the caller. Turn it into a null statement diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index 217c38a..36254ff 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -293,10 +293,9 @@ package body Exp_Put_Image is Loc : constant Source_Ptr := Sloc (N); P_Type : constant Entity_Id := Entity (Prefix (N)); U_Type : constant Entity_Id := Underlying_Type (P_Type); - FST : constant Entity_Id := First_Subtype (U_Type); Sink : constant Node_Id := First (Expressions (N)); Item : constant Node_Id := Next (Sink); - P_Size : constant Uint := Esize (FST); + P_Size : constant Uint := Esize (U_Type); Lib_RE : RE_Id; begin @@ -417,14 +416,48 @@ package body Exp_Put_Image is Lib_RE : RE_Id; use Stand; begin + pragma Assert (Is_String_Type (U_Type)); + pragma Assert (not RTU_Loaded (Interfaces_C) + or else Enclosing_Lib_Unit_Entity (U_Type) + /= RTU_Entity (Interfaces_C)); + if R = Standard_String then Lib_RE := RE_Put_Image_String; elsif R = Standard_Wide_String then Lib_RE := RE_Put_Image_Wide_String; elsif R = Standard_Wide_Wide_String then Lib_RE := RE_Put_Image_Wide_Wide_String; + else - raise Program_Error; + -- Handle custom string types. For example: + + -- type T is array (1 .. 10) of Character; + -- Obj : T := (others => 'A'); + -- ... + -- Put (Obj'Image); + + declare + C_Type : Entity_Id; + + begin + if Is_Private_Type (R) then + C_Type := Component_Type (Full_View (R)); + else + C_Type := Component_Type (R); + end if; + + C_Type := Root_Type (Underlying_Type (C_Type)); + + if C_Type = Standard_Character then + Lib_RE := RE_Put_Image_String; + elsif C_Type = Standard_Wide_Character then + Lib_RE := RE_Put_Image_Wide_String; + elsif C_Type = Standard_Wide_Wide_Character then + Lib_RE := RE_Put_Image_Wide_Wide_String; + else + raise Program_Error; + end if; + end; end if; -- Convert parameter to the required type (i.e. the type of the diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index 098e001..78eb27e 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -355,6 +355,18 @@ package body Exp_Tss is return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2); end Is_Init_Proc; + ------------------- + -- Is_Rep_To_Pos -- + ------------------- + + function Is_Rep_To_Pos (E : Entity_Id) return Boolean is + C1 : Character; + C2 : Character; + begin + Get_Last_Two_Chars (Chars (E), C1, C2); + return C1 = TSS_Rep_To_Pos (1) and then C2 = TSS_Rep_To_Pos (2); + end Is_Rep_To_Pos; + ------------ -- Is_TSS -- ------------ diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads index e7f3120..aed6a68 100644 --- a/gcc/ada/exp_tss.ads +++ b/gcc/ada/exp_tss.ads @@ -154,6 +154,11 @@ package Exp_Tss is -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Is_Rep_To_Pos (E : Entity_Id) return Boolean; + -- Version for Rep to Pos conversions, same as Is_TSS (E, TSS_Rep_To_Pos); + + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean; -- Determines if given entity (E) is the name of a TSS identified by Nam 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 ef8c91d..8b9ce9a 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); @@ -6748,6 +6742,7 @@ package body Exp_Util is | N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate + | N_Elsif_Part and then Nkind (Parent (Par)) not in N_Function_Call | N_Procedure_Call_Statement | N_Entry_Call_Statement @@ -8266,6 +8261,7 @@ package body Exp_Util is | N_Expanded_Name | N_Explicit_Dereference | N_Extension_Aggregate + | N_External_Initializer | N_Floating_Point_Definition | N_Formal_Decimal_Fixed_Point_Definition | N_Formal_Derived_Type_Definition @@ -8574,6 +8570,21 @@ package body Exp_Util is and then Is_Formal (Entity (N))); end Is_Conversion_Or_Reference_To_Formal; + -------------------------------------------------- + -- Is_Expanded_Class_Wide_Interface_Object_Decl -- + -------------------------------------------------- + + function Is_Expanded_Class_Wide_Interface_Object_Decl + (N : Node_Id) return Boolean is + begin + return not Comes_From_Source (N) + and then Nkind (Original_Node (N)) = N_Object_Declaration + and then Nkind (N) = N_Object_Renaming_Declaration + and then Is_Class_Wide_Type (Etype (Defining_Identifier (N))) + and then Is_Interface (Etype (Defining_Identifier (N))) + and then Nkind (Name (N)) = N_Explicit_Dereference; + end Is_Expanded_Class_Wide_Interface_Object_Decl; + ------------------------------ -- Is_Finalizable_Transient -- ------------------------------ @@ -8685,12 +8696,12 @@ package body Exp_Util is and then Nkind (Selector_Name (Param)) = N_Identifier then declare - Actual : constant Node_Id - := Explicit_Actual_Parameter (Param); - Formal : constant Node_Id - := Selector_Name (Param); - Name : constant String - := Get_Name_String (Chars (Formal)); + Actual : constant Node_Id := + Explicit_Actual_Parameter (Param); + Formal : constant Node_Id := + Selector_Name (Param); + Name : constant String := + Get_Name_String (Chars (Formal)); begin -- A nonnull BIPaccess has been found @@ -10320,8 +10331,8 @@ package body Exp_Util is pragma Assert (Has_Invariants (Typ)); Proc_Id : constant Entity_Id := Invariant_Procedure (Typ); pragma Assert (Present (Proc_Id)); - Inv_Typ : constant Entity_Id - := Base_Type (Etype (First_Formal (Proc_Id))); + Inv_Typ : constant Entity_Id := + Base_Type (Etype (First_Formal (Proc_Id))); Arg : Node_Id; @@ -11565,8 +11576,8 @@ package body Exp_Util is if All_Extensions_Allowed then declare - Rep : constant Node_Id - := Get_Rep_Item (Typ, Name_Finalizable, Check_Parents => True); + Rep : constant Node_Id := + Get_Rep_Item (Typ, Name_Finalizable, Check_Parents => True); Assoc : Node_Id; @@ -12709,11 +12720,11 @@ package body Exp_Util is -- was called). if Is_Array_Type (Exp_Type) then - Scope_Suppress.Suppress (Length_Check) - := Svg_Suppress.Suppress (Length_Check); + Scope_Suppress.Suppress (Length_Check) := + Svg_Suppress.Suppress (Length_Check); else - Scope_Suppress.Suppress (Discriminant_Check) - := Svg_Suppress.Suppress (Discriminant_Check); + Scope_Suppress.Suppress (Discriminant_Check) := + Svg_Suppress.Suppress (Discriminant_Check); end if; E := Make_Qualified_Expression (Loc, @@ -13055,14 +13066,14 @@ package body Exp_Util is begin -- Examine the list of actual and formal parameters in parallel - A := First (Parameter_Associations (Call)); + A := First_Actual (Call); F := First_Formal (Entity (Name (Call))); while Present (A) and then Present (F) loop if A = Actual then return Etype (F); end if; - Next (A); + Next_Actual (A); Next_Formal (F); end loop; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 14d9e34..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; @@ -773,6 +763,11 @@ package Exp_Util is -- Return True if N is a type conversion, or a dereference thereof, or a -- reference to a formal parameter. + function Is_Expanded_Class_Wide_Interface_Object_Decl + (N : Node_Id) return Boolean; + -- Determine if N is the expanded code for a class-wide interface type + -- object declaration. + function Is_Finalizable_Transient (Decl : Node_Id; N : Node_Id) return Boolean; diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index b4c1aea5..e3e65fe 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -179,8 +179,10 @@ extern void Get_Variant_Encoding (Entity_Id); /* exp_tss: */ #define Is_Init_Proc exp_tss__is_init_proc +#define Is_Rep_To_Pos exp_tss__is_rep_to_pos extern Boolean Is_Init_Proc (Entity_Id); +extern Boolean Is_Rep_To_Pos (Entity_Id); /* exp_util: */ @@ -345,11 +347,18 @@ extern void Set_Present_Expr (Node_Id, Uint); /* sinput: */ +struct c_array { + const char *pointer; + int length; +}; + +#define C_Source_Buffer sinput__c_source_buffer #define Debug_Source_Name sinput__debug_source_name #define Get_Column_Number sinput__get_column_number #define Get_Logical_Line_Number sinput__get_logical_line_number #define Get_Source_File_Index sinput__get_source_file_index +extern struct c_array C_Source_Buffer (Source_File_Index); extern File_Name_Type Debug_Source_Name (Source_File_Index); extern Column_Number_Type Get_Column_Number (Source_Ptr); extern Line_Number_Type Get_Logical_Line_Number (Source_Ptr); diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb index 983cda4..cb93634 100644 --- a/gcc/ada/fname-uf.adb +++ b/gcc/ada/fname-uf.adb @@ -93,6 +93,15 @@ package body Fname.UF is -- Table recording calls to Set_File_Name_Pattern. Note that the first two -- entries are set to represent the standard GNAT rules for file naming. + procedure Instantiate_SFN_Pattern + (Pattern : SFN_Pattern_Entry; + Buf : in out Bounded_String; + Is_Predef : Boolean := False); + -- On entry, Buf must contain a unit name. After returning, Buf contains + -- the file name corresponding to the unit following the naming pattern + -- described by Pattern. Is_Predef must be whether the unit name in Buf + -- is a predefined unit name as defined by Is_Predefined_Unit_Name. + ----------------------- -- File_Name_Of_Body -- ----------------------- @@ -164,6 +173,29 @@ package body Fname.UF is return Unknown; end Get_Expected_Unit_Type; + --------------------------- + -- Get_Default_File_Name -- + --------------------------- + + function Get_Default_File_Name (Uname : Unit_Name_Type) return String is + Buf : Bounded_String; + + Pattern : SFN_Pattern_Entry; + begin + Get_Unit_Name_String (Buf, Uname, False); + + if Is_Spec_Name (Uname) then + Pattern := SFN_Patterns.Table (1); + else + pragma Assert (Is_Body_Name (Uname)); + Pattern := SFN_Patterns.Table (2); + end if; + + Instantiate_SFN_Pattern (Pattern, Buf); + + return To_String (Buf); + end Get_Default_File_Name; + ------------------- -- Get_File_Name -- ------------------- @@ -261,23 +293,11 @@ package body Fname.UF is Name_Buffer (1 .. Name_Len); Pent : Nat; - Plen : Natural; Fnam : File_Name_Type := No_File; - J : Natural; - Dot : String_Ptr; - Dotl : Natural; Is_Predef : Boolean; -- Set True for predefined file - function C (N : Natural) return Character; - -- Return N'th character of pattern - - function C (N : Natural) return Character is - begin - return SFN_Patterns.Table (Pent).Pat (N); - end C; - -- Start of search through pattern table begin @@ -309,122 +329,8 @@ package body Fname.UF is Name_Len := Uname'Length; Name_Buffer (1 .. Name_Len) := Uname; - -- Apply casing, except that we do not do this for the case - -- of a predefined library file. For the latter, we always - -- use the all lower case name, regardless of the setting. - - if not Is_Predef then - Set_Casing (SFN_Patterns.Table (Pent).Cas); - end if; - - -- If dot translation required do it - - Dot := SFN_Patterns.Table (Pent).Dot; - Dotl := Dot.all'Length; - - if Dot.all /= "." then - J := 1; - - while J <= Name_Len loop - if Name_Buffer (J) = '.' then - - if Dotl = 1 then - Name_Buffer (J) := Dot (Dot'First); - - else - Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) := - Name_Buffer (J + 1 .. Name_Len); - Name_Buffer (J .. J + Dotl - 1) := Dot.all; - Name_Len := Name_Len + Dotl - 1; - end if; - - J := J + Dotl; - - -- Skip past wide char sequences to avoid messing with - -- dot characters that are part of a sequence. - - elsif Name_Buffer (J) = ASCII.ESC - or else (Upper_Half_Encoding - and then - Name_Buffer (J) in Upper_Half_Character) - then - Skip_Wide (Name_Buffer, J); - else - J := J + 1; - end if; - end loop; - end if; - - -- Here move result to right if preinsertion before * - - Plen := SFN_Patterns.Table (Pent).Pat'Length; - for K in 1 .. Plen loop - if C (K) = '*' then - if K /= 1 then - Name_Buffer (1 + K - 1 .. Name_Len + K - 1) := - Name_Buffer (1 .. Name_Len); - - for L in 1 .. K - 1 loop - Name_Buffer (L) := C (L); - end loop; - - Name_Len := Name_Len + K - 1; - end if; - - for L in K + 1 .. Plen loop - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := C (L); - end loop; - - exit; - end if; - end loop; - - -- Execute possible crunch on constructed name. The krunch - -- operation excludes any extension that may be present. - - J := Name_Len; - while J > 1 loop - exit when Name_Buffer (J) = '.'; - J := J - 1; - end loop; - - -- Case of extension present - - if J > 1 then - declare - Ext : constant String := Name_Buffer (J .. Name_Len); - - begin - -- Remove extension - - Name_Len := J - 1; - - -- Krunch what's left - - Krunch - (Name_Buffer, - Name_Len, - Integer (Maximum_File_Name_Length), - Debug_Flag_4); - - -- Replace extension - - Name_Buffer - (Name_Len + 1 .. Name_Len + Ext'Length) := Ext; - Name_Len := Name_Len + Ext'Length; - end; - - -- Case of no extension present, straight krunch on the - -- entire file name. - - else - Krunch - (Name_Buffer, - Name_Len, - Integer (Maximum_File_Name_Length), - Debug_Flag_4); - end if; + Instantiate_SFN_Pattern + (SFN_Patterns.Table (Pent), Global_Name_Buffer, Is_Predef); Fnam := Name_Find; @@ -543,6 +449,145 @@ package body Fname.UF is Cas => All_Lower_Case)); end Initialize; + ----------------------------- + -- Instantiate_SFN_Pattern -- + ----------------------------- + + procedure Instantiate_SFN_Pattern + (Pattern : SFN_Pattern_Entry; + Buf : in out Bounded_String; + Is_Predef : Boolean := False) + is + function C (N : Natural) return Character; + -- Return N'th character of pattern + + function C (N : Natural) return Character is + begin + return Pattern.Pat (N); + end C; + + Dot : constant String_Ptr := Pattern.Dot; + + Dotl : constant Natural := Dot.all'Length; + + Plen : constant Natural := Pattern.Pat'Length; + + J : Natural; + begin + -- Apply casing, except that we do not do this for the case + -- of a predefined library file. For the latter, we always + -- use the all lower case name, regardless of the setting. + + if not Is_Predef then + Set_Casing (Buf, Pattern.Cas); + end if; + + -- If dot translation required do it + + if Dot.all /= "." then + J := 1; + + while J <= Buf.Length loop + if Buf.Chars (J) = '.' then + + if Dotl = 1 then + Buf.Chars (J) := Dot (Dot'First); + + else + Buf.Chars (J + Dotl .. Buf.Length + Dotl - 1) := + Buf.Chars (J + 1 .. Buf.Length); + Buf.Chars (J .. J + Dotl - 1) := Dot.all; + Buf.Length := Buf.Length + Dotl - 1; + end if; + + J := J + Dotl; + + -- Skip past wide char sequences to avoid messing with + -- dot characters that are part of a sequence. + + elsif Buf.Chars (J) = ASCII.ESC + or else (Upper_Half_Encoding + and then + Buf.Chars (J) in Upper_Half_Character) + then + Skip_Wide (Buf.Chars, J); + else + J := J + 1; + end if; + end loop; + end if; + + -- Here move result to right if preinsertion before * + + for K in 1 .. Plen loop + if C (K) = '*' then + if K /= 1 then + Buf.Chars (1 + K - 1 .. Buf.Length + K - 1) := + Buf.Chars (1 .. Buf.Length); + + for L in 1 .. K - 1 loop + Buf.Chars (L) := C (L); + end loop; + + Buf.Length := Buf.Length + K - 1; + end if; + + for L in K + 1 .. Plen loop + Buf.Length := Buf.Length + 1; + Buf.Chars (Buf.Length) := C (L); + end loop; + + exit; + end if; + end loop; + + -- Execute possible crunch on constructed name. The krunch + -- operation excludes any extension that may be present. + + J := Buf.Length; + while J > 1 loop + exit when Buf.Chars (J) = '.'; + J := J - 1; + end loop; + + -- Case of extension present + + if J > 1 then + declare + Ext : constant String := Buf.Chars (J .. Buf.Length); + + begin + -- Remove extension + + Buf.Length := J - 1; + + -- Krunch what's left + + Krunch + (Buf.Chars, + Buf.Length, + Integer (Maximum_File_Name_Length), + Debug_Flag_4); + + -- Replace extension + + Buf.Chars + (Buf.Length + 1 .. Buf.Length + Ext'Length) := Ext; + Buf.Length := Buf.Length + Ext'Length; + end; + + -- Case of no extension present, straight krunch on the + -- entire file name. + + else + Krunch + (Buf.Chars, + Buf.Length, + Integer (Maximum_File_Name_Length), + Debug_Flag_4); + end if; + end Instantiate_SFN_Pattern; + ---------- -- Lock -- ---------- diff --git a/gcc/ada/fname-uf.ads b/gcc/ada/fname-uf.ads index a57e396..4c35212 100644 --- a/gcc/ada/fname-uf.ads +++ b/gcc/ada/fname-uf.ads @@ -53,6 +53,9 @@ package Fname.UF is -- be determined with the file naming conventions in use, then the returned -- value is set to Unknown. + function Get_Default_File_Name (Uname : Unit_Name_Type) return String; + -- Returns the file name of Uname under the default GNAT naming scheme. + function Get_File_Name (Uname : Unit_Name_Type; Subunit : Boolean; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 7d5be6b..882c026 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3287,7 +3287,7 @@ package body Freeze is ("aspect % applied to task type &", Typ); Error_Msg_N ("\replace task components with access-to-task-type " - & "components??", Typ); + & "components", Typ); end if; else @@ -5066,6 +5066,11 @@ package body Freeze is -- variants referenceed by the Variant_Part VP are frozen. This is -- a recursive routine to deal with nested variants. + procedure Warn_If_Implicitly_Inherited_Aspects (Tag_Typ : Entity_Id); + -- Report a warning for Tag_Typ when it implicitly inherits the + -- First_Controlling_Parameter aspect but does not explicitly + -- specify it. + ----------------- -- Check_Itype -- ----------------- @@ -5144,6 +5149,193 @@ package body Freeze is end loop; end Freeze_Choices_In_Variant_Part; + ------------------------------------------ + -- Warn_If_Implicitly_Inherited_Aspects -- + ------------------------------------------ + + procedure Warn_If_Implicitly_Inherited_Aspects (Tag_Typ : Entity_Id) + is + function Has_First_Ctrl_Param_Aspect return Boolean; + -- Determines if Tag_Typ explicitly has the aspect/pragma + -- First_Controlling_Parameter. + + --------------------------------- + -- Has_First_Ctrl_Param_Aspect -- + --------------------------------- + + function Has_First_Ctrl_Param_Aspect return Boolean is + Decl_Nod : constant Node_Id := Parent (Tag_Typ); + Asp_Nod : Node_Id; + Nod : Node_Id; + Pragma_Arg : Node_Id; + Pragma_Ent : Entity_Id; + + begin + pragma Assert (Nkind (Decl_Nod) = N_Full_Type_Declaration); + + if Present (Aspect_Specifications (Decl_Nod)) then + Asp_Nod := First (Aspect_Specifications (Decl_Nod)); + while Present (Asp_Nod) loop + if Chars (Identifier (Asp_Nod)) + = Name_First_Controlling_Parameter + then + return True; + end if; + + Next (Asp_Nod); + end loop; + end if; + + -- Search for the occurrence of the pragma + + Nod := Next (Decl_Nod); + while Present (Nod) loop + if Nkind (Nod) = N_Pragma + and then Chars (Pragma_Identifier (Nod)) + = Name_First_Controlling_Parameter + and then Present (Pragma_Argument_Associations (Nod)) + then + Pragma_Arg := + Expression (First (Pragma_Argument_Associations (Nod))); + + if Nkind (Pragma_Arg) = N_Identifier + and then Present (Entity (Pragma_Arg)) + then + Pragma_Ent := Entity (Pragma_Arg); + + if Pragma_Ent = Tag_Typ + or else + (Is_Concurrent_Type (Pragma_Ent) + and then + Corresponding_Record_Type (Pragma_Ent) + = Tag_Typ) + then + return True; + end if; + end if; + end if; + + Next (Nod); + end loop; + + return False; + end Has_First_Ctrl_Param_Aspect; + + -- Local Variables + + Has_Aspect_First_Ctrl_Param : constant Boolean := + Has_First_Ctrl_Param_Aspect; + + -- Start of processing for Warn_Implicitly_Inherited_Aspects + + begin + -- Handle cases where reporting the warning is not needed + + if not Warn_On_Non_Dispatching_Primitives then + return; + + -- No check needed when this is the full view of a private type + -- declaration since the pragma/aspect must be placed and checked + -- in the partial view, and it is implicitly propagated to the + -- full view. + + elsif Has_Private_Declaration (Tag_Typ) + and then Is_Tagged_Type (Incomplete_Or_Partial_View (Tag_Typ)) + then + return; + + -- Similar case but applied to concurrent types + + elsif Is_Concurrent_Record_Type (Tag_Typ) + and then Has_Private_Declaration + (Corresponding_Concurrent_Type (Tag_Typ)) + and then Is_Tagged_Type + (Incomplete_Or_Partial_View + (Corresponding_Concurrent_Type (Tag_Typ))) + then + return; + end if; + + if Etype (Tag_Typ) /= Tag_Typ + and then Has_First_Controlling_Parameter_Aspect (Etype (Tag_Typ)) + then + -- The attribute was implicitly inherited + pragma Assert + (Has_First_Controlling_Parameter_Aspect (Tag_Typ)); + + -- No warning needed when the current tagged type is not + -- an interface type since by definition the aspect is + -- implicitly propagated from its parent type; the warning + -- is reported on interface types since it may not be so + -- clear when some implemented interface types have the + -- aspect and other interface types don't have it. For + -- interface types, we don't report the warning when the + -- interface type is an extension of a single interface + -- type (for similarity with the behavior with regular + -- tagged types). + + if not Has_Aspect_First_Ctrl_Param + and then Is_Interface (Tag_Typ) + and then not Is_Empty_Elmt_List (Interfaces (Tag_Typ)) + then + Error_Msg_N + ("?_j?implicitly inherits aspect 'First_'Controlling_'" + & "Parameter!", Tag_Typ); + Error_Msg_NE + ("\?_j?from & and must be confirmed explicitly!", + Tag_Typ, Etype (Tag_Typ)); + end if; + + elsif Present (Interfaces (Tag_Typ)) + and then not Is_Empty_Elmt_List (Interfaces (Tag_Typ)) + then + -- To maintain consistency with the behavior when the aspect + -- is implicitly inherited from its parent type, we do not + -- report a warning for concurrent record types that implement + -- a single interface type. By definition, the aspect is + -- propagated from that interface type as if it were the parent + -- type. For example: + + -- type Iface is interface with First_Controlling_Parameter; + -- task type T is new Iface with ... + + if Is_Concurrent_Record_Type (Tag_Typ) + and then No (Next_Elmt (First_Elmt (Interfaces (Tag_Typ)))) + then + null; + + else + declare + Elmt : Elmt_Id := First_Elmt (Interfaces (Tag_Typ)); + Iface : Entity_Id; + + begin + while Present (Elmt) loop + Iface := Node (Elmt); + pragma Assert (Present (Iface)); + + if Has_First_Controlling_Parameter_Aspect (Iface) + and then not Has_Aspect_First_Ctrl_Param + then + pragma Assert + (Has_First_Controlling_Parameter_Aspect + (Tag_Typ)); + Error_Msg_N + ("?_j?implicitly inherits aspect 'First_'" + & "Controlling_'Parameter", Tag_Typ); + Error_Msg_NE + ("\?_j?from & and must be confirmed explicitly!", + Tag_Typ, Iface); + exit; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + end if; + end Warn_If_Implicitly_Inherited_Aspects; + -- Start of processing for Freeze_Record_Type begin @@ -5919,6 +6111,13 @@ package body Freeze is end loop; end; end if; + + -- For tagged types, warn on an implicitly inherited aspect/pragma + -- First_Controlling_Parameter that is not explicitly set. + + if Is_Tagged_Type (Rec) then + Warn_If_Implicitly_Inherited_Aspects (Rec); + end if; end Freeze_Record_Type; ------------------------------- @@ -7418,16 +7617,16 @@ package body Freeze is if Ada_Version >= Ada_2005 then Error_Msg_N - ("\would be legal if Storage_Size of 0 given??", E); + ("\would be legal if Storage_Size of 0 given", E); elsif No_Pool_Assigned (E) then Error_Msg_N - ("\would be legal in Ada 2005??", E); + ("\would be legal in Ada 2005", E); else Error_Msg_N ("\would be legal in Ada 2005 if " - & "Storage_Size of 0 given??", E); + & "Storage_Size of 0 given", E); end if; end if; end if; @@ -10276,6 +10475,86 @@ package body Freeze is then Check_Overriding_Indicator (E, Empty, Is_Primitive (E)); end if; + + -- Check illegal subprograms of tagged types and interface types that + -- have aspect/pragma First_Controlling_Parameter. + + if Comes_From_Source (E) + and then Is_Abstract_Subprogram (E) + then + if Is_Dispatching_Operation (E) then + if Ekind (E) = E_Function + and then Is_Interface (Etype (E)) + and then not Is_Class_Wide_Type (Etype (E)) + and then Has_First_Controlling_Parameter_Aspect + (Find_Dispatching_Type (E)) + then + Error_Msg_NE + ("'First_'Controlling_'Parameter disallows returning a " + & "non-class-wide interface type", + E, Etype (E)); + end if; + + else + -- The type of the formals cannot be an interface type + + if Present (First_Formal (E)) then + declare + Formal : Entity_Id := First_Formal (E); + Has_Aspect : Boolean := False; + + begin + -- Check if some formal has the aspect + + while Present (Formal) loop + if Is_Tagged_Type (Etype (Formal)) + and then + Has_First_Controlling_Parameter_Aspect + (Etype (Formal)) + then + Has_Aspect := True; + end if; + + Next_Formal (Formal); + end loop; + + -- If the aspect is present then report the error + + if Has_Aspect then + Formal := First_Formal (E); + + while Present (Formal) loop + if Is_Interface (Etype (Formal)) + and then not Is_Class_Wide_Type (Etype (Formal)) + then + Error_Msg_NE + ("not a dispatching primitive of interface type&", + E, Etype (Formal)); + Error_Msg_N + ("\disallowed by 'First_'Controlling_'Parameter " + & "aspect", E); + end if; + + Next_Formal (Formal); + end loop; + end if; + end; + end if; + + if Ekind (E) = E_Function + and then Is_Interface (Etype (E)) + and then not Is_Class_Wide_Type (Etype (E)) + and then Has_First_Controlling_Parameter_Aspect (Etype (E)) + then + Error_Msg_NE + ("not a dispatching primitive of interface type&", + E, Etype (E)); + Error_Msg_N + ("\disallowed by 'First_'Controlling_'Parameter " + & "aspect", E); + end if; + end if; + end if; end Freeze_Subprogram; ---------------------- @@ -10821,7 +11100,7 @@ package body Freeze is then Error_Msg_NE ("\packed array component& " & - "will be initialized to zero??", + "will be initialized to zero?o?", Nam, Comp); exit; else @@ -10833,7 +11112,7 @@ package body Freeze is Error_Msg_N ("\use pragma Import for & to " & - "suppress initialization (RM B.1(24))??", + "suppress initialization (RM B.1(24))?o?", Nam); end if; end Warn_Overlay; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index b284110..0b8f2dd 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 \ @@ -355,6 +365,7 @@ GNAT_ADA_OBJS = \ ada/fname.o \ ada/freeze.o \ ada/frontend.o \ + ada/generate_minimal_reproducer.o \ ada/get_targ.o \ ada/ghost.o \ ada/gnat_cuda.o \ @@ -482,6 +493,7 @@ GNAT1_C_OBJS+= \ ada/errno.o \ ada/init.o \ ada/initialize.o \ + ada/mkdir.o \ ada/raise.o \ ada/raise-gcc.o \ ada/rtfinal.o \ @@ -507,6 +519,7 @@ GNAT_ADA_OBJS+= \ ada/libgnat/g-speche.o \ ada/libgnat/g-table.o \ ada/libgnat/g-u3spch.o \ + ada/libgnat/i-c.o \ ada/libgnat/interfac.o \ ada/libgnat/s-addope.o \ ada/libgnat/s-addima.o \ @@ -594,6 +607,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 \ @@ -671,6 +694,7 @@ GNATBIND_OBJS += \ ada/libgnat/g-byorma.o \ ada/libgnat/g-hesora.o \ ada/libgnat/g-htable.o \ + ada/libgnat/i-c.o \ ada/libgnat/interfac.o \ ada/libgnat/s-addope.o \ ada/libgnat/s-assert.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..f22dea0 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); } @@ -1559,6 +1563,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) prepend_one_attribute_pragma (&attr_list, Linker_Section_Pragma (gnat_entity)); + /* Do not initialize Out parameters with -ftrivial-auto-var-init. */ + if (kind == E_Out_Parameter) + prepend_one_attribute + (&attr_list, ATTR_MACHINE_ATTRIBUTE, + get_identifier ("uninitialized"), NULL_TREE, + gnat_entity); + /* Now create the variable or the constant and set various flags. */ gnu_decl = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type, @@ -6561,7 +6572,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 +6594,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 +6615,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 +7693,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; } } @@ -9589,14 +9602,9 @@ validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object, old_size = max_size (old_size, true); /* If this is an access type or a fat pointer, the minimum size is that given - by the smallest integral mode that's valid for pointers. */ + by the default pointer mode. */ if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type)) - { - scalar_int_mode p_mode = NARROWEST_INT_MODE; - while (!targetm.valid_pointer_mode (p_mode)) - p_mode = GET_MODE_WIDER_MODE (p_mode).require (); - old_size = bitsize_int (GET_MODE_BITSIZE (p_mode)); - } + old_size = bitsize_int (GET_MODE_BITSIZE (ptr_mode)); /* Issue an error either if the default size of the object isn't a constant or if the new size is smaller than it. */ 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 f77629c..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++) @@ -784,7 +786,7 @@ gnat_get_array_descr_info (const_tree const_type, { tree type = const_cast<tree> (const_type); tree first_dimen, dimen; - bool is_bit_packed_array, is_array; + bool is_array; int i; /* Temporaries created in the first pass and used in the second one for thin @@ -797,12 +799,7 @@ gnat_get_array_descr_info (const_tree const_type, /* If we have an implementation type for a packed array, get the original array type. */ if (TYPE_IMPL_PACKED_ARRAY_P (type) && TYPE_ORIGINAL_PACKED_ARRAY (type)) - { - is_bit_packed_array = BIT_PACKED_ARRAY_TYPE_P (type); - type = TYPE_ORIGINAL_PACKED_ARRAY (type); - } - else - is_bit_packed_array = false; + type = TYPE_ORIGINAL_PACKED_ARRAY (type); /* First pass: gather all information about this array except everything related to dimensions. */ @@ -833,6 +830,14 @@ gnat_get_array_descr_info (const_tree const_type, tree array_field = DECL_CHAIN (bounds_field); tree array_type = TREE_TYPE (array_field); + /* Replay the entire processing for array types. */ + if (TYPE_CAN_HAVE_DEBUG_TYPE_P (array_type) + && TYPE_DEBUG_TYPE (array_type)) + array_type = TYPE_DEBUG_TYPE (array_type); + if (TYPE_IMPL_PACKED_ARRAY_P (array_type) + && TYPE_ORIGINAL_PACKED_ARRAY (array_type)) + array_type = TYPE_ORIGINAL_PACKED_ARRAY (array_type); + /* Shift back the address to get the address of the template. */ tree shift_amount = fold_build1 (NEGATE_EXPR, sizetype, byte_position (array_field)); @@ -859,9 +864,7 @@ gnat_get_array_descr_info (const_tree const_type, /* If this array has fortran convention, it's arranged in column-major order, so our view here has reversed dimensions. */ const bool convention_fortran_p = TYPE_CONVENTION_FORTRAN_P (first_dimen); - - if (BIT_PACKED_ARRAY_TYPE_P (first_dimen)) - is_bit_packed_array = true; + const bool is_bit_packed_array = BIT_PACKED_ARRAY_TYPE_P (first_dimen); /* ??? For row major ordering, we probably want to emit nothing and instead specify it as the default in Dw_TAG_compile_unit. */ @@ -1128,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..a073b2d 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); } } @@ -6119,7 +6124,12 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) gnu_index = convert (gnu_type, gnu_index); } + /* Do not print the range information for an enumeration type with + holes since it is meaningless. */ if (with_extra_info + && !(Nkind (gnat_index) == N_Function_Call + && Is_Entity_Name (Name (gnat_index)) + && Is_Rep_To_Pos (Entity (Name (gnat_index)))) && Known_Esize (gnat_type) && UI_To_Int (Esize (gnat_type)) <= 32) gnu_result @@ -6396,6 +6406,17 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = build_atomic_load (gnu_result, aa_sync); break; + case N_External_Initializer: + { + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + struct c_array a = C_Source_Buffer (File_Index (gnat_node)); + + gnu_result = build_string ((unsigned) a.length, a.pointer); + + TREE_TYPE (gnu_result) = gnu_result_type; + } + break; + case N_Integer_Literal: { tree gnu_type; @@ -10286,12 +10307,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 +10660,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 +10686,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..a88a238 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -107,6 +107,7 @@ static tree handle_malloc_attribute (tree *, tree, tree, int, bool *); static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *); static tree handle_flatten_attribute (tree *, tree, tree, int, bool *); static tree handle_used_attribute (tree *, tree, tree, int, bool *); +static tree handle_uninitialized_attribute (tree *, tree, tree, int, bool *); static tree handle_cold_attribute (tree *, tree, tree, int, bool *); static tree handle_hot_attribute (tree *, tree, tree, int, bool *); static tree handle_simd_attribute (tree *, tree, tree, int, bool *); @@ -214,6 +215,8 @@ static const attribute_spec gnat_internal_attributes[] = handle_flatten_attribute, NULL }, { "used", 0, 0, true, false, false, false, handle_used_attribute, NULL }, + { "uninitialized",0, 0, true, false, false, false, + handle_uninitialized_attribute, NULL }, { "cold", 0, 0, true, false, false, false, handle_cold_attribute, attr_cold_hot_exclusions }, { "hot", 0, 0, true, false, false, false, @@ -2220,7 +2223,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)) @@ -7171,6 +7174,30 @@ handle_used_attribute (tree *pnode, tree name, tree ARG_UNUSED (args), return NULL_TREE; } +/* Handle an "uninitialized" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_uninitialized_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree decl = *node; + if (!VAR_P (decl)) + { + warning (OPT_Wattributes, "%qE attribute ignored because %qD " + "is not a variable", name, decl); + *no_add_attrs = true; + } + else if (TREE_STATIC (decl) || DECL_EXTERNAL (decl)) + { + warning (OPT_Wattributes, "%qE attribute ignored because %qD " + "is not a local variable", name, decl); + *no_add_attrs = true; + } + + return NULL_TREE; +} + /* Handle a "cold" and attribute; arguments as in struct attribute_spec.handler. */ diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc index 0d7e03e..8eebf59 100644 --- a/gcc/ada/gcc-interface/utils2.cc +++ b/gcc/ada/gcc-interface/utils2.cc @@ -661,7 +661,7 @@ fast_modulo_reduction (tree op, tree modulus, unsigned int precision) if (type_precision < BITS_PER_WORD) { const scalar_int_mode m - = smallest_int_mode_for_size (type_precision + 1); + = smallest_int_mode_for_size (type_precision + 1).require (); tree new_type = gnat_type_for_mode (m, 1); op = fold_convert (new_type, op); modulus = fold_convert (new_type, modulus); @@ -721,7 +721,8 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs, for its mode since operations are ultimately performed in the mode. */ if (TYPE_PRECISION (type) < precision) { - const scalar_int_mode m = smallest_int_mode_for_size (precision); + const scalar_int_mode m + = smallest_int_mode_for_size (precision).require (); op_type = gnat_type_for_mode (m, 1); modulus = fold_convert (op_type, modulus); lhs = fold_convert (op_type, lhs); diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 22fd1e3..dcebab6 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -182,6 +182,7 @@ package Gen_IL.Fields is Expression, Expression_Copy, Expressions, + File_Index, First_Bit, First_Inlined_Subprogram, First_Name, @@ -575,6 +576,7 @@ package Gen_IL.Fields is Has_Enumeration_Rep_Clause, Has_Exit, Has_Expanded_Contract, + Has_First_Controlling_Parameter_Aspect, Has_Forward_Instantiation, Has_Fully_Qualified_Name, Has_Ghost_Predicate_Aspect, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 29b22c6..4d2444e 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -478,6 +478,9 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Has_Dispatch_Table, Flag, Pre => "Is_Tagged_Type (N)"), Sm (Has_Dynamic_Predicate_Aspect, Flag), + Sm (Has_First_Controlling_Parameter_Aspect, Flag, + Pre => "Is_Tagged_Type (N) or else Is_Concurrent_Type (N)" + & " or else Is_Concurrent_Record_Type (N)"), Sm (Has_Ghost_Predicate_Aspect, Flag), Sm (Has_Inheritable_Invariants, Flag, Base_Type_Only), Sm (Has_Inherited_DIC, Flag, Base_Type_Only), diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 327ff37..d211343 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -461,6 +461,9 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sy (Actions, List_Id, Default_No_List), Sy (Expression, Node_Id, Default_Empty))); + Cc (N_External_Initializer, N_Subexpr, + (Sy (File_Index, Source_File_Index))); + Cc (N_If_Expression, N_Subexpr, (Sy (Expressions, List_Id, Default_No_List), Sy (Is_Elsif, Flag), diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb index 7e58a2c..0f7abe7 100644 --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -872,6 +872,7 @@ package body Gen_IL.Gen is | Uint | Uint_Subtype | Ureal + | Source_File_Index | Source_Ptr | Union_Id | Node_Id diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb index e08397f..c26d3fa 100644 --- a/gcc/ada/gen_il-internals.adb +++ b/gcc/ada/gen_il-internals.adb @@ -279,6 +279,8 @@ package body Gen_IL.Internals is return "DT_Position"; when Forwards_OK => return "Forwards_OK"; + when Has_First_Controlling_Parameter_Aspect => + return "Has_First_Controlling_Parameter_Aspect"; when Has_Inherited_DIC => return "Has_Inherited_DIC"; when Has_Own_DIC => diff --git a/gcc/ada/gen_il-types.ads b/gcc/ada/gen_il-types.ads index 48de818..f2a6595 100644 --- a/gcc/ada/gen_il-types.ads +++ b/gcc/ada/gen_il-types.ads @@ -60,6 +60,7 @@ package Gen_IL.Types is Upos, Nonzero_Uint, Ureal, + Source_File_Index, Node_Kind_Type, -- Type of result of Nkind function, i.e. Node_Kind Entity_Kind_Type, -- Type of result of Ekind function, i.e. Entity_Kind @@ -249,6 +250,7 @@ package Gen_IL.Types is N_String_Literal, N_Explicit_Dereference, N_Expression_With_Actions, + N_External_Initializer, N_If_Expression, N_Indexed_Component, N_Interpolated_String_Literal, diff --git a/gcc/ada/generate_minimal_reproducer.adb b/gcc/ada/generate_minimal_reproducer.adb new file mode 100644 index 0000000..ffef91b --- /dev/null +++ b/gcc/ada/generate_minimal_reproducer.adb @@ -0,0 +1,464 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G E N E R A T E _ M I N I M A L _ R E P R O D U C E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 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 AdaCore. -- +-- -- +------------------------------------------------------------------------------ + +with Fmap; +with Fname.UF; +with Lib; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; +with Sinfo.Nodes; +with System.CRTL; +with System.OS_Lib; use System.OS_Lib; +with Types; use Types; + +procedure Generate_Minimal_Reproducer is + Reproducer_Generation_Failed : exception; + + function Create_Reproducer_Directory return String; + -- Create a directory that will be used to run adareducer, and will + -- eventually contain the reduced set of sources to be collected by the + -- user. The name of the directory makes its purpose clear, and it has a + -- numeric suffix to avoid clashes with other compiler invocations that + -- might have generated reproducers already. + + --------------------------------- + -- Create_Reproducer_Directory -- + --------------------------------- + + function Create_Reproducer_Directory return String is + Max_Id : constant Positive := 1000; + + Prefix : constant String := "reduce-crash-reproducer"; + + Result : System.CRTL.int; + begin + for Id in 1 .. Max_Id loop + declare + Candidate_Path : String := Prefix & Positive'Image (Id); + begin + Candidate_Path (Prefix'Length + 1) := '-'; + + Result := System.CRTL.mkdir (Candidate_Path & ASCII.NUL); + + -- If mkdir fails, we assume that it's because the directory + -- already exists. We should check for EEXIST instead??? + if Result = 0 then + return Candidate_Path; + end if; + end; + end loop; + + Write_Line ("failed to create reproducer directory"); + raise Reproducer_Generation_Failed; + end Create_Reproducer_Directory; + + Dirname : constant String := Create_Reproducer_Directory; + + Gpr_File_Path : constant String := + Dirname & Directory_Separator & "reduce_crash_reproducer.gpr"; + + Src_Dir_Path : constant String := Dirname & Directory_Separator & "src"; + + Oracle_Path : constant String := + Dirname & Directory_Separator & Executable_Name ("oracle"); + + Result : Integer; +begin + Create_Semantic_Closure_Project : + declare + Gpr_File : File_Descriptor; + + B : constant Saved_Output_Buffer := Save_Output_Buffer; + begin + Gpr_File := Create_File (Gpr_File_Path, Text); + if Gpr_File = Invalid_FD then + Write_Line ("failed to create GPR file"); + raise Reproducer_Generation_Failed; + end if; + + Push_Output; + Set_Output (Gpr_File); + + Write_Line ("project Reduce_Crash_Reproducer is"); + Write_Line (" for Source_Dirs use (""src"");"); + Write_Line ("end Reduce_Crash_Reproducer;"); + + Close (Gpr_File); + Pop_Output; + Restore_Output_Buffer (B); + + Result := System.CRTL.mkdir (Src_Dir_Path & ASCII.NUL); + + if Result /= 0 then + Write_Line ("failed to create reproducer directory"); + raise Reproducer_Generation_Failed; + end if; + + for J in Main_Unit .. Lib.Last_Unit loop + declare + Path : File_Name_Type := + Fmap.Mapped_Path_Name (Lib.Unit_File_Name (J)); + + Default_File_Name : constant String := + Fname.UF.Get_Default_File_Name (Lib.Unit_Name (J)); + + File_Copy_Path : constant String := + Src_Dir_Path & Directory_Separator & Default_File_Name; + + -- We may have synthesized units for child subprograms without + -- spec files. We need to filter out those units because we would + -- create bogus spec files that break compilation if we didn't. + Is_Synthetic_Subprogram_Spec : constant Boolean := + not Sinfo.Nodes.Comes_From_Source (Lib.Cunit (J)); + begin + if not Lib.Is_Internal_Unit (J) + and then not Is_Synthetic_Subprogram_Spec + then + -- Mapped_Path_Name might have returned No_File. This has been + -- observed for files with a Source_File_Name pragma. + if Path = No_File then + Path := Find_File (Lib.Unit_File_Name (J), Osint.Source); + pragma Assert (Path /= No_File); + end if; + + declare + File_Path : constant String := Get_Name_String (Path); + Success : Boolean; + begin + System.OS_Lib.Copy_File + (File_Path, File_Copy_Path, Success, Overwrite); + + pragma Assert (Success); + end; + end if; + end; + end loop; + end Create_Semantic_Closure_Project; + + Create_Oracle : + declare + Gnatmake_Path : String_Access := Locate_Exec_On_Path ("gnatmake"); + + Oracle_Dir_Path : constant String := + Dirname & Directory_Separator & "oracle-src"; + + Source_File_Path : constant String := + Oracle_Dir_Path & Directory_Separator & "oracle.adb"; + + Source_File : File_Descriptor; + + Result : System.CRTL.int; + begin + if Gnatmake_Path = null then + Write_Line ("-gnatd_m was specified but gnatmake is not available"); + raise Reproducer_Generation_Failed; + end if; + + Result := System.CRTL.mkdir (Oracle_Dir_Path & ASCII.NUL); + + if Result /= 0 then + Write_Line ("failed to create directory"); + raise Reproducer_Generation_Failed; + end if; + + Source_File := Create_File (Source_File_Path, Text); + if Source_File = Invalid_FD then + Write_Line ("failed to create oracle source file"); + raise Reproducer_Generation_Failed; + end if; + + Write_Oracle_Code : + declare + Old_Main_Path : constant String := + Get_Name_String + (Fmap.Mapped_Path_Name (Lib.Unit_File_Name (Main_Unit))); + + Default_Main_Name : constant String := + Fname.UF.Get_Default_File_Name (Lib.Unit_Name (Main_Unit)); + + New_Main_Path : constant String := + Src_Dir_Path & Directory_Separator & Default_Main_Name; + + Gnat1_Path : String (1 .. Len_Arg (0)); + + B : constant Saved_Output_Buffer := Save_Output_Buffer; + begin + Fill_Arg (Gnat1_Path'Address, 0); + + Push_Output; + Set_Output (Source_File); + + Write_Line ("with Ada.Command_Line;"); + Write_Line ("use Ada.Command_Line;"); + Write_Line ("with GNAT.Expect;"); + Write_Line ("with GNAT.OS_Lib;"); + Write_Eol; + Write_Line ("procedure Oracle is"); + Write_Line (" Child_Code : aliased Integer;"); + Write_Eol; + Write_Line (" Gnat1_Path : constant String := "); + + Write_Str (" """); + Write_Str (Gnat1_Path); + Write_Line (""";"); + + Write_Eol; + Write_Line (" Args : constant GNAT.OS_Lib.Argument_List :="); + + Write_Str (" (new String'(""-gnatd_M"")"); + + -- The following way of iterating through the command line arguments + -- was copied from Set_Targ. TODO factorize??? + declare + type Arg_Array is array (Nat) of Big_String_Ptr; + type Arg_Array_Ptr is access Arg_Array; + -- Types to access compiler arguments + + save_argc : Nat; + pragma Import (C, save_argc); + -- Saved value of argc (number of arguments), imported from + -- misc.cc + + save_argv : Arg_Array_Ptr; + pragma Import (C, save_argv); + -- Saved value of argv (argument pointers), imported from misc.cc + + gnat_argc : Nat; + gnat_argv : Arg_Array_Ptr; + pragma Import (C, gnat_argc); + pragma Import (C, gnat_argv); + -- If save_argv is not set, default to gnat_argc/argv + + argc : Nat; + argv : Arg_Array_Ptr; + + function Len_Arg (Arg : Big_String_Ptr) return Nat; + -- Determine length of argument Arg (a nul terminated C string). + + ------------- + -- Len_Arg -- + ------------- + + function Len_Arg (Arg : Big_String_Ptr) return Nat is + begin + for J in 1 .. Nat'Last loop + if Arg (Natural (J)) = ASCII.NUL then + return J - 1; + end if; + end loop; + + raise Program_Error; + end Len_Arg; + + begin + if save_argv /= null then + argv := save_argv; + argc := save_argc; + else + -- Case of a non-GCC compiler, e.g. gnat2why or gnat2scil + argv := gnat_argv; + argc := gnat_argc; + end if; + + for Arg in 1 .. argc - 1 loop + declare + Argv_Ptr : constant Big_String_Ptr := argv (Arg); + Argv_Len : constant Nat := Len_Arg (Argv_Ptr); + + Arg : constant String := Argv_Ptr (1 .. Natural (Argv_Len)); + begin + -- We filter out mapping file arguments because we want to + -- use the copies of source files we made. + if Argv_Len > 8 and then Arg (1 .. 8) = "-gnatem=" then + null; + + -- We must not have the oracle run the compiler in + -- reduce-on-crash mode, that would result in recursive + -- invocations. + elsif Arg = "-gnatd_m" then + null; + else + Write_Line (","); + Write_Str (" new String'("""); + + -- We replace references to the main source file with + -- references to the copy we made. + if Old_Main_Path = Arg then + Write_Str (New_Main_Path); + + -- We copy the other command line arguments unmodified + else + Write_Str (Arg); + end if; + + Write_Str (""")"); + end if; + end; + end loop; + end; + + Write_Line (");"); + + Write_Eol; + + Write_Line (" Output : constant String :="); + Write_Line (" GNAT.Expect.Get_Command_Output"); + Write_Str (" (Gnat1_Path, Args, """", Child_Code'Access, "); + Write_Line ("Err_To_Out => True);"); + + Write_Eol; + + Write_Line (" Crash_Marker : constant String :="); + Write_Line (" ""+===========================GNAT BUG DETECTE"";"); + + Write_Eol; + + Write_Line (" Crashed : constant Boolean :="); + Write_Line (" Crash_Marker'Length <= Output'Length"); + Write_Str (" and then Output (Output'First .. Output'First "); + Write_Line ("+ Crash_Marker'Length - 1)"); + Write_Line (" = Crash_Marker;"); + + Write_Eol; + + Write_Str (" Status_Code : Exit_Status := "); + Write_Line ("(if Crashed then 0 else 1);"); + Write_Line ("begin"); + Write_Line (" Set_Exit_Status (Status_Code);"); + Write_Line ("end Oracle;"); + + Pop_Output; + Restore_Output_Buffer (B); + end Write_Oracle_Code; + + Close (Source_File); + + declare + Args : constant Argument_List := + (new String'(Source_File_Path), + new String'("-o"), + new String'(Oracle_Path), + new String'("-D"), + new String'(Oracle_Dir_Path)); + + Success : Boolean; + begin + Spawn (Gnatmake_Path.all, Args, Success); + + pragma Assert (Success); + end; + + Free (Gnatmake_Path); + end Create_Oracle; + + Run_Adareducer : + declare + -- See section 12.8.3 of the GNAT Studio user's guide for documentation + -- about how to invoke adareducer. + Gnatstudio_Cli_Path : String_Access := + Locate_Exec_On_Path ("gnatstudio_cli"); + + begin + if Gnatstudio_Cli_Path = null then + Write_Line ("-gnatd_m was specified but adareducer is not available"); + return; + end if; + + declare + Args : constant Argument_List := + (new String'("adareducer"), + new String'("-P"), + new String'(Gpr_File_Path), + new String'("-s"), + new String'(Oracle_Path)); + + Success : Boolean; + begin + Spawn (Gnatstudio_Cli_Path.all, Args, Success); + pragma Assert (Success); + end; + + Free (Gnatstudio_Cli_Path); + end Run_Adareducer; + + Clean_Up_Reproducer_Source : + declare + + use type System.Address; + + Directory_Stream : System.CRTL.DIRs; + + function opendir (file_name : String) return System.CRTL.DIRs with + Import, Convention => C, External_Name => "__gnat_opendir"; + + Conservative_Name_Max : constant Positive := 4096; + + Buffer : String (1 .. Conservative_Name_Max); + Length : aliased Integer; + + Addr : System.Address; + + Dummy : Integer; + + Dummy_Success : Boolean; + + function readdir + (Directory : System.CRTL.DIRs; + Buffer : System.Address; + Length : access Integer) return System.Address + with Import, Convention => C, External_Name => "__gnat_readdir"; + + function closedir (directory : System.CRTL.DIRs) return Integer with + Import, Convention => C, External_Name => "__gnat_closedir"; + + begin + Directory_Stream := opendir (Src_Dir_Path & ASCII.NUL); + + if Directory_Stream = System.Null_Address then + return; + end if; + + loop + Addr := readdir (Directory_Stream, Buffer'Address, Length'Access); + if Addr = System.Null_Address then + exit; + end if; + + declare + S : constant String := Buffer (1 .. Length); + begin + if (5 <= S'Length and then S (S'Last - 4 .. S'Last) = ".orig") + or else (2 <= S'Length and then S (S'Last - 1 .. S'Last) = ".s") + then + System.OS_Lib.Delete_File + (Src_Dir_Path & Directory_Separator & S, Dummy_Success); + end if; + end; + end loop; + + Dummy := closedir (Directory_Stream); + end Clean_Up_Reproducer_Source; +end Generate_Minimal_Reproducer; diff --git a/gcc/ada/gnat-style.texi b/gcc/ada/gnat-style.texi index 29b4c88..d0ba53a 100644 --- a/gcc/ada/gnat-style.texi +++ b/gcc/ada/gnat-style.texi @@ -3,7 +3,7 @@ @setfilename gnat-style.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 5.3.0.@* +@*Generated by Sphinx 8.0.2.@* @end ifinfo @settitle GNAT Coding Style A Guide for GNAT Developers @defindex ge @@ -19,7 +19,7 @@ @copying @quotation -GNAT Coding Style: A Guide for GNAT Developers , Dec 21, 2023 +GNAT Coding Style: A Guide for GNAT Developers , Oct 07, 2024 AdaCore diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 3a766cc..732fdb0 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -3,7 +3,7 @@ @setfilename gnat_rm.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 5.3.0.@* +@*Generated by Sphinx 8.0.2.@* @end ifinfo @settitle GNAT Reference Manual @defindex ge @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Jul 29, 2024 +GNAT Reference Manual , Oct 07, 2024 AdaCore @@ -895,22 +895,46 @@ GNAT language extensions Curated Extensions * Local Declarations Without Block:: -* Conditional when constructs:: * Fixed lower bounds for array types and subtypes:: * Prefixed-view notation for calls to primitive subprograms of untagged types:: * Expression defaults for generic formal functions:: * String interpolation:: * Constrained attribute for generic objects:: * Static aspect on intrinsic functions:: +* First Controlling Parameter:: Experimental Language Extensions +* Conditional when constructs:: * Storage Model:: * Attribute Super:: * Simpler accessibility model:: * Case pattern matching:: * Mutably Tagged Types with Size’Class Aspect:: * Generalized Finalization:: +* No_Raise aspect:: +* Inference of Dependent Types in Generic Instantiations:: +* External_Initialization Aspect:: + +Storage Model + +* Aspect Storage_Model_Type:: +* Aspect Designated_Storage_Model:: +* Legacy Storage Pools:: + +Simpler accessibility model + +* Standalone objects:: +* Subprogram parameters:: +* Function results:: +* Discriminants and allocators:: + +No_Raise aspect + +* New specification for Ada.Finalization.Controlled: New specification for Ada Finalization Controlled. +* Finalized tagged types:: +* Composite types:: +* Interoperability with controlled types:: Security Hardening Features @@ -9191,7 +9215,7 @@ also be used as a configuration pragma. The fourth form, with an @code{On|Off} parameter and a string, is used to control individual messages, based on their text. The string argument is a pattern that is used to match against the text of individual -warning messages (not including the initial “warning: ” tag). +warning messages (not including the initial “warning: “ tag). The pattern may contain asterisks, which match zero or more characters in the message. For example, you can use @@ -28924,7 +28948,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 @@ -28937,26 +28962,32 @@ for use in playground experiments. @section Curated Extensions +Features activated via @code{-gnatX} or +@code{pragma Extensions_Allowed (On)}. + @menu * Local Declarations Without Block:: -* Conditional when constructs:: * Fixed lower bounds for array types and subtypes:: * Prefixed-view notation for calls to primitive subprograms of untagged types:: * Expression defaults for generic formal functions:: * String interpolation:: * Constrained attribute for generic objects:: * Static aspect on intrinsic functions:: +* First Controlling Parameter:: @end menu -@node Local Declarations Without Block,Conditional when constructs,,Curated Extensions +@node Local Declarations Without Block,Fixed lower bounds for array types and subtypes,,Curated Extensions @anchor{gnat_rm/gnat_language_extensions local-declarations-without-block}@anchor{445} @subsection Local Declarations Without Block -A basic_declarative_item may appear at the place of any statement. -This avoids the heavy syntax of block_statements just to declare -something locally. +A @code{basic_declarative_item} may appear at the place of any statement. This +avoids the heavy syntax of block_statements just to declare something locally. + +The only valid kind of declarations for now are @code{object_declaration}, +@code{object_renaming_declaration}, @code{use_package_clause} and +@code{use_type_clause}. For example: @@ -28970,83 +29001,76 @@ if X > 5 then end if; @end example -Link to the original RFC: -@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-local-vars-without-block.md} - -@node Conditional when constructs,Fixed lower bounds for array types and subtypes,Local Declarations Without Block,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions conditional-when-constructs}@anchor{446} -@subsection Conditional when constructs +It is generally a good practice to declare local variables (or constants) with as +short a lifetime as possible. However, introducing a declare block to accomplish +this is a relatively heavy syntactic load along with a traditional extra level +of indentation. The alternative syntax supported here allows declaring symbols +in any statement sequence. Lifetime of such local declarations is until the end of +the enclosing construct. The same enclosing construct cannot contain several +declarations of the same symbol; however, overriding symbols from higher-level +scopes works similarly to the explicit @code{declare} block. +If the enclosing construct allows an exception handler (such as an accept +statement, begin-except-end block or a subprogram body), declarations that +appear at the place of a statement are `not' visible within the handler. Only +declarations that precede the beginning of the construct with an exception +handler would be visible in this handler. -This feature extends the use of @code{when} as a way to condition a control-flow -related statement, to all control-flow related statements. +@cartouche +@quotation Attention +Here are a couple of examples illustrating the scoping rules described above. -To do a conditional return in a procedure the following syntax should be used: +@quotation -@example -procedure P (Condition : Boolean) is -begin - return when Condition; -end; -@end example -This will return from the procedure if @code{Condition} is true. +@enumerate -When being used in a function the conditional part comes after the return value: +@item +Those declarations are not visible from the potential exception handler: @example -function Is_Null (I : Integer) return Boolean is begin - return True when I = 0; - return False; + A : Integer + ... +exception + when others => + Put_Line (A'Image) -- ILLEGAL end; @end example -In a similar way to the @code{exit when} a @code{goto ... when} can be employed: +@item +The following is legal @example -procedure Low_Level_Optimized is - Flags : Bitmapping; +declare + A : Integer := 10; begin - Do_1 (Flags); - goto Cleanup when Flags (1); - - Do_2 (Flags); - goto Cleanup when Flags (32); - - -- ... - -<<Cleanup>> - -- ... + A : Integer := 12; end; @end example -@c code-block - -To use a conditional raise construct: +because it is roughly expanded into @example -procedure Foo is -begin - raise Error when Imported_C_Func /= 0; -end; -@end example - -An exception message can also be added: + declare + A : Integer := 10; + begin + declare + A : Integer := 12; + begin + ... + end; + end; -@example -procedure Foo is -begin - raise Error with "Unix Error" - when Imported_C_Func /= 0; -end; +And as such the second `@w{`}A`@w{`} declaration is hiding the first one. @end example +@end enumerate +@end quotation +@end quotation +@end cartouche -Link to the original RFC: -@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-conditional-when-constructs.rst} - -@node Fixed lower bounds for array types and subtypes,Prefixed-view notation for calls to primitive subprograms of untagged types,Conditional when constructs,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions fixed-lower-bounds-for-array-types-and-subtypes}@anchor{447} +@node Fixed lower bounds for array types and subtypes,Prefixed-view notation for calls to primitive subprograms of untagged types,Local Declarations Without Block,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions fixed-lower-bounds-for-array-types-and-subtypes}@anchor{446} @subsection Fixed lower bounds for array types and subtypes @@ -29096,11 +29120,8 @@ the efficiency of indexing operations, since the compiler statically knows the lower bound of unconstrained array formals when the formal’s subtype has index ranges with static fixed lower bounds. -Link to the original RFC: -@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-fixed-lower-bound.rst} - @node Prefixed-view notation for calls to primitive subprograms of untagged types,Expression defaults for generic formal functions,Fixed lower bounds for array types and subtypes,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions prefixed-view-notation-for-calls-to-primitive-subprograms-of-untagged-types}@anchor{448} +@anchor{gnat_rm/gnat_language_extensions prefixed-view-notation-for-calls-to-primitive-subprograms-of-untagged-types}@anchor{447} @subsection Prefixed-view notation for calls to primitive subprograms of untagged types @@ -29115,7 +29136,7 @@ This same notation is already available for tagged types. This extension allows for untagged types. It is allowed for all primitive operations of the type independent of whether they were originally declared in a package spec or its private part, or were inherited and/or overridden as part of a derived type -declaration occuring anywhere, so long as the first parameter is of the type, +declaration occurring anywhere, so long as the first parameter is of the type, or an access parameter designating the type. For example: @@ -29149,11 +29170,8 @@ pragma Assert (V.Length = 2); pragma Assert (V.Nth_Element(1) = 42); @end example -Link to the original RFC: -@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-prefixed-untagged.rst} - @node Expression defaults for generic formal functions,String interpolation,Prefixed-view notation for calls to primitive subprograms of untagged types,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions expression-defaults-for-generic-formal-functions}@anchor{449} +@anchor{gnat_rm/gnat_language_extensions expression-defaults-for-generic-formal-functions}@anchor{448} @subsection Expression defaults for generic formal functions @@ -29178,11 +29196,18 @@ private end Stacks; @end example +@cartouche +@quotation Todo +I do not understand this feature enough to decide if the description above +is sufficient for documentation. +@end quotation +@end cartouche + Link to the original RFC: @indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-expression-functions-as-default-for-generic-formal-function-parameters.rst} @node String interpolation,Constrained attribute for generic objects,Expression defaults for generic formal functions,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions string-interpolation}@anchor{44a} +@anchor{gnat_rm/gnat_language_extensions string-interpolation}@anchor{449} @subsection String interpolation @@ -29332,19 +29357,16 @@ Put_Line f" an open brace is \@{"); @end example -Link to the original RFC: -@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-string-interpolation.md} - @node Constrained attribute for generic objects,Static aspect on intrinsic functions,String interpolation,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions constrained-attribute-for-generic-objects}@anchor{44b} +@anchor{gnat_rm/gnat_language_extensions constrained-attribute-for-generic-objects}@anchor{44a} @subsection Constrained attribute for generic objects The @code{Constrained} attribute is permitted for objects of generic types. The result indicates whether the corresponding actual is constrained. -@node Static aspect on intrinsic functions,,Constrained attribute for generic objects,Curated Extensions -@anchor{gnat_rm/gnat_language_extensions static-aspect-on-intrinsic-functions}@anchor{44c} +@node Static aspect on intrinsic functions,First Controlling Parameter,Constrained attribute for generic objects,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions static-aspect-on-intrinsic-functions}@anchor{44b} @subsection @code{Static} aspect on intrinsic functions @@ -29352,38 +29374,479 @@ The Ada 202x @code{Static} aspect can be specified on Intrinsic imported functio and the compiler will evaluate some of these intrinsics statically, in particular the @code{Shift_Left} and @code{Shift_Right} intrinsics. +@node First Controlling Parameter,,Static aspect on intrinsic functions,Curated Extensions +@anchor{gnat_rm/gnat_language_extensions first-controlling-parameter}@anchor{44c} +@subsection First Controlling Parameter + + +A new pragma/aspect, @code{First_Controlling_Parameter}, is introduced for tagged +types, altering the semantics of primitive/controlling parameters. When a +tagged type is marked with this aspect, only subprograms where the first +parameter is of that type will be considered dispatching primitives. This +pragma/aspect applies to the entire hierarchy, starting from the specified +type, without affecting inherited primitives. + +Here is an example of this feature: + +@example +package Example is + type Root is tagged private; + + procedure P (V : Integer; V2 : Root); + -- Primitive + + type Child is tagged private + with First_Controlling_Parameter; + +private + type Root is tagged null record; + type Child is new Root with null record; + + overriding + procedure P (V : Integer; V2 : Child); + -- Primitive + + procedure P2 (V : Integer; V2 : Child); + -- NOT Primitive + + function F return Child; -- NOT Primitive + + function F2 (V : Child) return Child; + -- Primitive, but only controlling on the first parameter +end; +@end example + +Note that @code{function F2 (V : Child) return Child;} differs from @code{F2 (V : Child) +return Child'Class;} in that the return type is a specific, definite type. This +is also distinct from the legacy semantics, where further derivations with +added fields would require overriding the function. + +The option @code{-gnatw_j}, that you can pass to the compiler directly, enables +warnings related to this new language feature. For instance, compiling the +example above without this switch produces no warnings, but compiling it with +@code{-gnatw_j} generates the following warning on the declaration of procedure P2: + +@example +warning: not a dispatching primitive of tagged type "Child" +warning: disallowed by First_Controlling_Parameter on "Child" +@end example + +For generic formal tagged types, you can specify whether the type has the +First_Controlling_Parameter aspect enabled: + +@example +generic + type T is tagged private with First_Controlling_Parameter; +package T is + type U is new T with null record; + function Foo return U; -- Not a primitive +end T; +@end example + +For tagged partial views, the value of the aspect must be consistent between +the partial and full views: + +@example +package R is + type T is tagged private; +... +private + type T is tagged null record with First_Controlling_Parameter; -- ILLEGAL +end R; +@end example + +Restricting the position of controlling parameter offers several advantages: + + +@itemize * + +@item +Simplification of the dispatching rules improves readability of Ada programs. +One doesn’t need to analyze all subprogram parameters to understand if the given +subprogram is a primitive of a certain tagged type. + +@item +A programmer is free to use any type, including classwide types, on other +parameters of a subprogram, without the need to consider possible effects of +overriding a primitive or creating new one. + +@item +Return type of a function is never considered as a controlling parameter. +@end itemize + @node Experimental Language Extensions,,Curated Extensions,GNAT language extensions -@anchor{gnat_rm/gnat_language_extensions experimental-language-extensions}@anchor{6a}@anchor{gnat_rm/gnat_language_extensions id2}@anchor{44d} +@anchor{gnat_rm/gnat_language_extensions experimental-language-extensions}@anchor{6a}@anchor{gnat_rm/gnat_language_extensions id3}@anchor{44d} @section Experimental Language Extensions +Features activated via @code{-gnatX0} or +@code{pragma Extensions_Allowed (All_Extensions)}. + @menu +* Conditional when constructs:: * Storage Model:: * Attribute Super:: * Simpler accessibility model:: * Case pattern matching:: * Mutably Tagged Types with Size’Class Aspect:: * Generalized Finalization:: +* No_Raise aspect:: +* Inference of Dependent Types in Generic Instantiations:: +* External_Initialization Aspect:: @end menu -@node Storage Model,Attribute Super,,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions storage-model}@anchor{44e} +@node Conditional when constructs,Storage Model,,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions conditional-when-constructs}@anchor{44e} +@subsection Conditional when constructs + + +This feature extends the use of @code{when} as a way to condition a control-flow +related statement, to all control-flow related statements. + +To do a conditional return in a procedure the following syntax should be used: + +@example +procedure P (Condition : Boolean) is +begin + return when Condition; +end; +@end example + +This will return from the procedure if @code{Condition} is true. + +When being used in a function the conditional part comes after the return value: + +@example +function Is_Null (I : Integer) return Boolean is +begin + return True when I = 0; + return False; +end; +@end example + +In a similar way to the @code{exit when} a @code{goto ... when} can be employed: + +@example +procedure Low_Level_Optimized is + Flags : Bitmapping; +begin + Do_1 (Flags); + goto Cleanup when Flags (1); + + Do_2 (Flags); + goto Cleanup when Flags (32); + + -- ... + +<<Cleanup>> + -- ... +end; +@end example + +@c code-block + +To use a conditional raise construct: + +@example +procedure Foo is +begin + raise Error when Imported_C_Func /= 0; +end; +@end example + +An exception message can also be added: + +@example +procedure Foo is +begin + raise Error with "Unix Error" + when Imported_C_Func /= 0; +end; +@end example + +@node Storage Model,Attribute Super,Conditional when constructs,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions storage-model}@anchor{44f} @subsection Storage Model -This feature proposes to redesign the concepts of Storage Pools into a more -efficient model allowing higher performances and easier integration with low -footprint embedded run-times. +This extends Storage Pools into a more efficient model allowing higher performances, +easier integration with low footprint embedded run-times and copying data between +different pools of memory. The latter is especially useful when working with distributed +memory models, in particular to support interactions with GPU. + +@menu +* Aspect Storage_Model_Type:: +* Aspect Designated_Storage_Model:: +* Legacy Storage Pools:: + +@end menu + +@node Aspect Storage_Model_Type,Aspect Designated_Storage_Model,,Storage Model +@anchor{gnat_rm/gnat_language_extensions aspect-storage-model-type}@anchor{450} +@subsubsection Aspect Storage_Model_Type + + +A Storage model is a type which is associated with an aspect +“Storage_Model_Type”, e.g.: + +@example +type A_Model is null record + with Storage_Model_Type; +@end example + +Storage_Model_Type itself accepts six parameters: + + +@itemize - + +@item +Address_Type, the type of the address managed by this model. This has to be +a scalar type or derived from System.Address. + +@item +Allocate, a procedure used for allocating memory in this model + +@item +Deallocate, a procedure used for deallocating memory in this model + +@item +Copy_To, a procedure used to copy memory from native memory to this model + +@item +Copy_From, a procedure used to copy memory from this model to native memory + +@item +Storage_Size, a function returning the amount of memory left + +@item +Null_Address, a value for the null address value +@end itemize + +By default, Address_Type is System.Address, and all other five subprograms are +performing native operations (e.g. the allocator is the native new allocator). +Users can decide to specify one or more of these. When an Address_Type is +specified and different than System.Address, the all other five subprograms have +to be specified. + +The prototypes of these procedures are as follows: + +@example +procedure Allocate + (Model : in out A_Model; + Storage_Address : out Address_Type; + Size : Storage_Count; + Alignment : Storage_Count); + +procedure Deallocate + (Model : in out A_Model; + Storage_Address : out Address_Type; + Size : Storage_Count; + Alignment : Storage_Count); + +procedure Copy_To + (Model : in out A_Model; + Target : Address_Type; + Source : System.Address; + Size : Storage_Count); + +procedure Copy_From + (Model : in out A_Model; + Target : System.Address; + Source : Address_Type; + Size : Storage_Count); + +function Storage_Size + (Pool : A_Model) + return Storage_Count; +@end example + +Here’s an example of how this could be instantiated in the context of CUDA: + +@example +package CUDA_Memory is + + type CUDA_Storage_Model is null record + with Storage_Model_Type => ( + Address_Type => CUDA_Address, + Allocate => CUDA_Allocate, + Deallocate => CUDA_Deallocate, + Copy_To => CUDA_Copy_To, + Copy_From => CUDA_Copy_From, + Storage_Size => CUDA_Storage_Size, + Null_Address => CUDA_Null_Address + ); + + type CUDA_Address is new System.Address; + -- We're assuming for now same address size on host and device + + procedure CUDA_Allocate + (Model : in out CUDA_Storage_Model; + Storage_Address : out CUDA_Address; + Size : Storage_Count; + Alignment : Storage_Count); + + procedure CUDA_Deallocate + (Model : in out CUDA_Storage_Model; + Storage_Address : out CUDA_Address; + Size : Storage_Count; + Alignment : Storage_Count); + + procedure CUDA_Copy_To + (Model : in out CUDA_Storage_Model; + Target : CUDA_Address; + Source : System.Address; + Size : Storage_Count); + + procedure CUDA_Copy_From + (Model : in out CUDA_Storage_Model; + Target : System.Address; + Source : CUDA_Address; + Size : Storage_Count); + + function CUDA_Storage_Size + (Pool : CUDA_Storage_Model) + return Storage_Count return Storage_Count'Last; + + CUDA_Null_Address : constant CUDA_Address := + CUDA_Address (System.Null_Address); -It also extends it to support distributed memory models, in particular to -support interactions with GPU. + CUDA_Memory : CUDA_Storage_Model; + +end CUDA_Memory; +@end example + +@node Aspect Designated_Storage_Model,Legacy Storage Pools,Aspect Storage_Model_Type,Storage Model +@anchor{gnat_rm/gnat_language_extensions aspect-designated-storage-model}@anchor{451} +@subsubsection Aspect Designated_Storage_Model + + +A new aspect, Designated_Storage_Model, allows to specify the memory model +for the objects pointed by an access type. Under this aspect, allocations +and deallocations will come from the specified memory model instead +of the standard ones. In addition, if write operations are needed for +initialization, or if there is a copy of the target object from and to a +standard memory area, the Copy_To and Copy_From functions will be called. +It allows to encompass the capabilities of storage pools, e.g.: + +@example +procedure Main is + type Integer_Array is array (Integer range <>) of Integer; + + type Host_Array_Access is access all Integer_Array; + type Device_Array_Access is access Integer_Array + with Designated_Storage_Model => CUDA_Memory; + + procedure Free is new Unchecked_Deallocation + (Host_Array_Type, Host_Array_Access); + procedure Free is new Unchecked_Deallocation + (Device_Array_Type, Device_Array_Access); + + Host_Array : Host_Array_Access := new Integer_Array (1 .. 10); + + Device_Array : Device_Array_Access := new Host_Array (1 .. 10); + -- Calls CUDA_Storage_Model.Allocate to allocate the fat pointers and + -- the bounds, then CUDA_Storage_Model.Copy_In to copy the values of the + -- boundaries. +begin + Host_Array.all := (others => 0); + + Device_Array.all := Host_Array.all; + -- Calls CUDA_Storage_Model.Copy_To to write to the device array from the + -- native memory. + + Host_Array.all := Device_Array.all; + -- Calls CUDA_Storage_Model.Copy_From to read from the device array and + -- write to native memory. + + Free (Host_Array); + + Free (Device_Array); + -- Calls CUDA_Storage_Model.Deallocate; +end; +@end example + +Taking ‘Address of an object with a specific memory model returns an object of +the type of the address for that memory category, which may be different from +System.Address. + +When copying is performed between two specific memory models, the native memory +is used as a temporary between the two. E.g.: + +@example +type Foo_I is access Integer with Designated_Storage_Model => Foo; +type Bar_I is access Integer with Designated_Storage_Model => Bar; + + X : Foo_I := new Integer; + Y : Bar_I := new Integer; +begin + X.all := Y.all; +@end example + +conceptually becomes: + +@example + X : Foo_I := new Integer; + T : Integer; + Y : Bar_I := new Integer; +begin + T := Y.all; + X.all := T; +@end example + +@node Legacy Storage Pools,,Aspect Designated_Storage_Model,Storage Model +@anchor{gnat_rm/gnat_language_extensions legacy-storage-pools}@anchor{452} +@subsubsection Legacy Storage Pools -Here is a link to the full RFC: -@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-storage-model.rst} + +Legacy Storage Pools are now replaced by a Storage_Model_Type. +They are implemented as follows: + +@example +type Root_Storage_Pool is abstract + new Ada.Finalization.Limited_Controlled with private +with Storage_Model_Type => ( + Allocate => Allocate, + Deallocate => Deallocate, + Storage_Size => Storage_Size +); +pragma Preelaborable_Initialization (Root_Storage_Pool); + +procedure Allocate + (Pool : in out Root_Storage_Pool; + Storage_Address : out System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) +is abstract; + +procedure Deallocate + (Pool : in out Root_Storage_Pool; + Storage_Address : System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) +is abstract; + +function Storage_Size + (Pool : Root_Storage_Pool) + return System.Storage_Elements.Storage_Count +is abstract; +@end example + +The legacy notation: + +@example +type My_Pools is new Root_Storage_Pool with record [...] + +My_Pool_Instance : Storage_Model_Pool.Storage_Model := + My_Pools'(others => <>); + +type Acc is access Integer_Array with Storage_Pool => My_Pool; +@end example + +can still be accepted as a shortcut for the new syntax. @node Attribute Super,Simpler accessibility model,Storage Model,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions attribute-super}@anchor{44f} +@anchor{gnat_rm/gnat_language_extensions attribute-super}@anchor{453} @subsection Attribute Super @@ -29392,49 +29855,376 @@ Here is a link to the full RFC: The @code{Super} attribute can be applied to objects of tagged types in order to obtain a view conversion to the most immediate specific parent type. -It cannot be applied to objects of types without any ancestors, or types whose -immediate parent is abstract. +It cannot be applied to objects of types without any ancestors. @example type T1 is tagged null record; procedure P (V : T1); type T2 is new T1 with null record; -procedure P (V : T2); -procedure Call (V : T2'Class) is +type T3 is new T2 with null record; +procedure P (V : T3); + +procedure Call ( + V1 : T1'Class; + V2 : T2'Class; + V3 : T3'Class) is begin - V'Super.P; -- Equivalent to "P (T1 (V));", a nondispatching call - -- to T1's primitive procedure P. + V1'Super.P; -- Illegal call as T1 doesn't have any ancestors + V2'Super.P; -- Equivalent to "T1 (V).P;", a non-dispatching call + -- to T1's primitive procedure P. + V3'Super.P; -- Equivalent to "T2 (V).P;"; Since T2 doesn't + -- override P, a non-dispatching call to T1.P is + -- executed. end; @end example -Here is a link to the full RFC: -@indicateurl{https://github.com/QuentinOchem/ada-spark-rfcs/blob/oop/considered/rfc-oop-super.rst} - @node Simpler accessibility model,Case pattern matching,Attribute Super,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions simpler-accessibility-model}@anchor{450} +@anchor{gnat_rm/gnat_language_extensions simpler-accessibility-model}@anchor{454} @subsection Simpler accessibility model -The goal of this feature is to restore a common understanding of accessibility -rules for implementers and users alike. The new rules should both be effective -at preventing errors and feel natural and compatible in an Ada environment -while removing dynamic accessibility checking. +The goal of this feature is to simplify the accessibility rules by removing +dynamic accessibility checks that are often difficult to understand and debug. +The new rules are effective at preventing errors, at the expense of loosing +some flexibility in the use of anonymous access types. + +The feature can be activated with pragma “No_Dynamic_Accessibility_Checks”. +As a result, a set of restrictions apply that can be categorized into three +use-case of anonymous access types: + + +@itemize * + +@item +standalone objects, + +@item +subprogam parameters and + +@item +function results. +@end itemize + +Each of those use-cases is explained separately below. All of the refined rules are +compatible with the [use of anonymous access types in SPARK] +(@indicateurl{http://docs.adacore.com/spark2014-docs/html/lrm/declarations-and-types.html#access-types}). + +@menu +* Standalone objects:: +* Subprogram parameters:: +* Function results:: +* Discriminants and allocators:: + +@end menu + +@node Standalone objects,Subprogram parameters,,Simpler accessibility model +@anchor{gnat_rm/gnat_language_extensions standalone-objects}@anchor{455} +@subsubsection Standalone objects + + +@example +Var : access T := ... +Var_To_Cst : access constant T := ... +Cst : constant access T := ... +Cst_To_Cst : constant access constant T := ... +@end example + +The accessibility levels of standalone objects of anonymous access type (both +constants or variables) is derived of the level of their object declaration. +This supports many common use-cases without the employment of @code{Unchecked_Access} +while still removing the need for dynamic checks. + +The most major benefit of this change is the compatibility with standard Ada rules. + +For example, the following assignment is legal without @code{Unchecked_Access} that +would be required without using the No_Dynamic_Accessibility_Checks pragma: + +@example +pragma Restrictions (No_Dynamic_Accessibility_Checks); + +procedure Accessibility is + + type T is null record; + type T_Ptr is access all T; + + T_Inst : aliased T; + Anon : access T := T_Inst'Access; + Named : T_Ptr := Anon; -Here is a link to the full RFC: -@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-simpler-accessibility.md} +begin + null; +end; +@end example + +@node Subprogram parameters,Function results,Standalone objects,Simpler accessibility model +@anchor{gnat_rm/gnat_language_extensions subprogram-parameters}@anchor{456} +@subsubsection Subprogram parameters + + +@example +procedure P (V : access T; X : access constant T); +@end example + +When the type of a formal parameter is of anonymous access then, from the caller’s +perspective, its level is seen to be at least as deep as that of the type of the +corresponding actual parameter (whatever that actual parameter might be) - +meaning any actual can be used for an anonymous access parameter without the use +of ‘Unchecked_Access. + +@cartouche +@quotation Todo +the example below doesn’t demonstrate the feature – X’Access is legal in plain Ada. +@end quotation +@end cartouche + +@example +pragma Restrictions (No_Dynamic_Accessibility_Checks); + +procedure Accessibility is + + procedure Foo (Param : access Integer) is null; + X : aliased Integer; +begin + Foo (X'Access); +end; +@end example + +From the callee’s perspective, the level of anonymous access formal parameters would be +between the level of the subprogram and the level of the subprogram’s locals. This has the effect +of formal parameters being treated as local to the callee except in: + + +@itemize * + +@item +Use as a function result + +@item +Use as a value for an access discriminant in result object + +@item +Use as an assignments between formal parameters +@end itemize + +Note that with these more restricted rules we lose track of accessibility levels when assigned to +local objects thus making (in the example below) the assignment to Node2.Link from Temp below +compile-time illegal. + +@cartouche +@quotation Todo +the code below gives the same error messages with and without the pragma +@end quotation +@end cartouche + +@example +type Node is record + Data : Integer; + Link : access Node; +end record; + +procedure Swap_Links (Node1, Node2 : in out Node) is + Temp : constant access Integer := Node1.Link; -- We lose the "association" to Node1 +begin + Node1.Link := Node2.Link; -- Allowed + Node2.Link := Temp; -- Not allowed +end; + +function Identity (N : access Node) return access Node is + Local : constant access Node := N; +begin + if True then + return N; -- Allowed + else + return Local; -- Not allowed + end if; +end; +@end example + +@node Function results,Discriminants and allocators,Subprogram parameters,Simpler accessibility model +@anchor{gnat_rm/gnat_language_extensions function-results}@anchor{457} +@subsubsection Function results + + +@example +function Get (X : Rec) return access T; +@end example + +@cartouche +@quotation Todo +clarify the list/reword +@end quotation +@end cartouche + +The accessibility level of the result of a call to a function that has an anonymous access result type defined to be as +whatever is deepest out of the following: + + +@itemize * + +@item +The level of the subprogram + +@item +The level of any actual parameter corresponding to a formal parameter of an anonymous access type + +@item +The level of each parameter that has a part with both one or more access discriminants and an unconstrained subtype + +@item +The level of any actual parameter corresponding to a formal parameter which is explicitly aliased +@end itemize + +NOTE: We would need to include an additional item in the list if we were not to enforce the below restriction on tagged types: + + +@itemize * + +@item +The level of any actual parameter corresponding to a formal parameter of a tagged type +@end itemize + +Function result example: + +@cartouche +@quotation Todo +verify the examples. Clarify, if they define expected behavior with the pragma or general restriction +that is modified by the pragma +@end quotation +@end cartouche + +@example +declare + type T is record + Comp : aliased Integer; + end record; + + function Identity (Param : access Integer) return access Integer is + begin + return Param; -- Legal + end; + + function Identity_2 (Param : aliased Integer) return access Integer is + begin + return Param'Access; -- Legal + end; + + X : access Integer; +begin + X := Identity (X); -- Legal + declare + Y : access Integer; + Z : aliased Integer; + begin + X := Identity (Y); -- Illegal since Y is too deep + X := Identity_2 (Z); -- Illegal since Z is too deep + end; +end; +@end example + +However, an additional restriction that falls out of the above logic is that tagged type extensions `cannot' +allow additional anonymous access discriminants in order to prevent upward conversions potentially making +such “hidden” anonymous access discriminants visible and prone to memory leaks. + +@cartouche +@quotation Todo +verify the examples. Clarify, if they define expected behavior with the pragma or general restriction +that is modified by the pragma +@end quotation +@end cartouche + +Here is an example of one such case of an upward conversion which would lead to a memory leak: + +@example +declare + type T is tagged null record; + type T2 (Disc : access Integer) is new T with null record; -- Must be illegal + + function Identity (Param : aliased T'Class) return access Integer is + begin + return T2 (T'Class (Param)).Disc; -- Here P gets effectively returned and set to X + end; + + X : access Integer; +begin + declare + P : aliased Integer; + Y : T2 (P'Access); + begin + X := Identity (T'Class (Y)); -- Pass local variable P (via Y's discriminant), + -- leading to a memory leak. + end; +end; +`@w{`}` + +Thus we need to make the following illegal to avoid such situations: + +`@w{`}`ada +package Pkg1 is + type T1 is tagged null record; + function Func (X1 : T1) return access Integer is (null); +end; + +package Pkg2 is + type T2 (Ptr1, Ptr2 : access Integer) is new Pkg1.T1 with null record; -- Illegal + ... +end; +@end example + +In order to prevent upward conversions of anonymous function results (like below), we +also would need to assure that the level of such a result (from the callee’s perspective) +is statically deeper: + +@cartouche +@quotation Todo +verify the examples. Clarify, if they define expected behavior with the pragma or general restriction +that is modified by the pragma +@end quotation +@end cartouche + +@example +declare + type Ref is access all Integer; + Ptr : Ref; + function Foo (Param : access Integer) return access Integer is + begin + return Result : access Integer := Param; do + Ptr := Ref (Result); -- Not allowed + end return; + end; +begin + declare + Local : aliased Integer; + begin + Foo (Local'Access).all := 123; + end; +end; +@end example + +@node Discriminants and allocators,,Function results,Simpler accessibility model +@anchor{gnat_rm/gnat_language_extensions discriminants-and-allocators}@anchor{458} +@subsubsection Discriminants and allocators + + +@cartouche +@quotation Todo +I have removed this section as it was referring to a feature which was never +implemented by gnat. Double-check that this is correct. +@end quotation +@end cartouche @node Case pattern matching,Mutably Tagged Types with Size’Class Aspect,Simpler accessibility model,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions case-pattern-matching}@anchor{451} +@anchor{gnat_rm/gnat_language_extensions case-pattern-matching}@anchor{459} @subsection Case pattern matching -The selector for a case statement (but not yet for a case expression) may be of a composite type, subject to -some restrictions (described below). Aggregate syntax is used for choices -of such a case statement; however, in cases where a “normal” aggregate would -require a discrete value, a discrete subtype may be used instead; box -notation can also be used to match all values. +The selector for a case statement (but not for a case expression) may +be of a composite type, subject to some restrictions (described below). +Aggregate syntax is used for choices of such a case statement; however, +in cases where a “normal” aggregate would require a discrete value, a +discrete subtype may be used instead; box notation can also be used to +match all values. Consider this example: @@ -29509,7 +30299,7 @@ matched (and the first one did not), then the actual parameters will be reversed. Within the choice list for single alternative, each choice must define the same -set of bindings and the component subtypes for for a given identifer must all +set of bindings and the component subtypes for for a given identifier must all statically match. Currently, the case of a binding for a nondiscrete component is not implemented. @@ -29554,23 +30344,17 @@ compile-time capacity limits in some annoyingly common scenarios; the message generated in such cases is usually “Capacity exceeded in compiling case statement with composite selector type”. -Link to the original RFC: -@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/master/prototyped/rfc-pattern-matching.rst} - @node Mutably Tagged Types with Size’Class Aspect,Generalized Finalization,Case pattern matching,Experimental Language Extensions -@anchor{gnat_rm/gnat_language_extensions mutably-tagged-types-with-size-class-aspect}@anchor{452} +@anchor{gnat_rm/gnat_language_extensions mutably-tagged-types-with-size-class-aspect}@anchor{45a} @subsection Mutably Tagged Types with Size’Class Aspect -The @cite{Size’Class} aspect can be applied to a tagged type to specify a size +The @code{Size'Class} aspect can be applied to a tagged type to specify a size constraint for the type and its descendants. When this aspect is specified on a tagged type, the class-wide type of that type is considered to be a “mutably tagged” type - meaning that objects of the class-wide type can have their tag changed by assignment from objects with a different tag. -When the aspect is applied to a type, the size of each of its descendant types -must not exceed the size specified for the aspect. - Example: @example @@ -29582,7 +30366,7 @@ type Derived_Type is new Base with record end record; -- ERROR if Derived_Type exceeds 16 bytes @end example -Class-wide types with a specified @cite{Size’Class} can be used as the type of +Class-wide types with a specified @code{Size'Class} can be used as the type of array components, record components, and stand-alone objects. @example @@ -29590,25 +30374,120 @@ Inst : Base'Class; type Array_of_Base is array (Positive range <>) of Base'Class; @end example -Note: Legality of the @cite{Size’Class} aspect is subject to certain restrictions on -the tagged type, such as being undiscriminated, having no dynamic composite -subcomponents, among others detailed in the RFC. +If the @code{Size'Class} aspect is specified for a type @code{T}, then every +specific descendant of @code{T} [redundant: (including @code{T})] -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 -@anchor{gnat_rm/gnat_language_extensions generalized-finalization}@anchor{453} +@itemize - + +@item +shall have a Size that does not exceed the specified value; and + +@item +shall be undiscriminated; and + +@item +shall have no composite subcomponent whose subtype is subject to a +dynamic constraint; and + +@item +shall have no interface progenitors; and + +@item +shall not have a tagged partial view other than a private extension; and + +@item +shall not have a statically deeper accessibility level than that of @code{T}. +@end itemize + +In addition to the places where Legality Rules normally apply (see 12.3), +these legality rules apply also in the private part and in the body of an +instance of a generic unit. + +For any subtype @code{S} that is a subtype of a descendant of @code{T}, @code{S'Class'Size} is +defined to yield the specified value [redundant:, although @code{S'Class'Size} is +not a static expression]. + +A class-wide descendant of a type with a specified @code{Size'Class} aspect is +defined to be a “mutably tagged” type. Any subtype of a mutably tagged type is, +by definition, a definite subtype (RM 3.3 notwithstanding). Default +initialization of an object of such a definite subtype proceeds as for the +corresponding specific type, except that @code{Program_Error} is raised if the +specific type is abstract. [In particular, the initial tag of the object is +that of the corresponding specific type.] + +An object of a tagged type is defined to be “tag-constrained” if it is + + +@itemize - + +@item +an object whose type is not mutably tagged; or + +@item +a constant object; or + +@item +a view conversion of a tag-constrained object; or + +@item +a formal @code{in out} or @code{out} parameter whose corresponding +actual parameter is tag-constrained. +@end itemize + +In the case of an assignment to a tagged variable that +is not tag-constrained, no check is performed that the tag of the value of +the expression is the same as that of the target (RM 5.2 notwithstanding). +Instead, the tag of the target object becomes that of the source object of +the assignment. +An assignment to a composite object similarly copies the tags of any +sub-components of the source object that have a mutably-tagged type. + +The @code{Constrained} attribute is defined for any name denoting an object of a +mutably tagged type (RM 3.7.2 notwithstanding). In this case, the Constrained +attribute yields the value True if the object is tag-constrained and False +otherwise. + +Renaming is not allowed (see 8.5.1) for a type conversion having an operand of +a mutably tagged type @code{MT} and a target type @code{TT} such that @code{TT'Class} +does not cover @code{MT}, nor for any part of such an object, nor for any slice +of such an object. This rule also applies in any context where a name is +required to be one for which “renaming is allowed” (for example, see RM 12.4). + +A name denoting a view of a variable of a mutably tagged type shall not +occur as an operative constituent of the prefix of a name denoting a +prefixed view of a callable entity, except as the callee name in a call to +the callable entity. + +For a type conversion between two general access types, either both or neither +of the designated types shall be mutably tagged. For an @code{Access} (or +@code{Unchecked_Access}) attribute reference, the designated type of the type of the +attribute reference and the type of the prefix of the attribute shall either +both or neither be mutably tagged. + +The execution of a construct is erroneous if the construct has a constituent +that is a name denoting a sub-component of a tagged object and the object’s +tag is changed by this execution between evaluating the name and the last use +(within this execution) of the subcomponent denoted by the name. + +If the type of a formal parameter is a specific tagged type then the execution +of the call is erroneous if the tag of the actual is changed while the formal +parameter exists (that is, before leaving the corresponding callable +construct). + +@node Generalized Finalization,No_Raise aspect,Mutably Tagged Types with Size’Class Aspect,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions generalized-finalization}@anchor{45b} @subsection Generalized Finalization -The @cite{Finalizable} aspect can be applied to any record type, tagged or not, -to specify that it provides the same level of control on the operations of initialization, finalization, and assignment of objects as the controlled +The @code{Finalizable} aspect can be applied to any record type, tagged or not, +to specify that it provides the same level of control on the operations of +initialization, finalization, and assignment of objects as the controlled types (see RM 7.6(2) for a high-level overview). The only restriction is that the record type must be a root type, in other words not a derived type. The aspect additionally makes it possible to specify relaxed semantics for -the finalization operations by means of the @cite{Relaxed_Finalization} setting. +the finalization operations by means of the @code{Relaxed_Finalization} setting. Example: @@ -29626,11 +30505,330 @@ procedure Finalize (Obj : in out Ctrl); procedure Initialize (Obj : in out Ctrl); @end example -Link to the original RFC: -@indicateurl{https://github.com/AdaCore/ada-spark-rfcs/blob/topic/finalization-rehaul/considered/rfc-generalized-finalization.md} +The three procedures have the same profile, taking a single @code{in out T} +parameter. + +We follow the same dynamic semantics as controlled objects: + +@quotation + + +@itemize - + +@item +@code{Initialize} is called when an object of type @code{T} is declared without +default expression. + +@item +@code{Adjust} is called after an object of type @code{T} is assigned a new value. + +@item +@code{Finalize} is called when an object of type @code{T} goes out of scope (for +stack-allocated objects) or is explicitly deallocated (for heap-allocated +objects). It is also called when on the value being replaced in an +assignment. +@end itemize +@end quotation + +However the following differences are enforced by default when compared to the +current Ada controlled-objects finalization model: + + +@itemize * + +@item +No automatic finalization of heap allocated objects: @code{Finalize} is only +called when an object is implicitly deallocated. As a consequence, no-runtime +support is needed for the implicit case, and no header will be maintained for +this in heap-allocated controlled objects. + +Heap-allocated objects allocated through a nested access type definition will +hence `not' be deallocated either. The result is simply that memory will be +leaked in those cases. + +@item +The @code{Finalize} procedure should have have the @ref{45c,,No_Raise aspect} specified. +If that’s not the case, a compilation error will be raised. +@end itemize + +Additionally, two other configuration aspects are added, +@code{Legacy_Heap_Finalization} and @code{Exceptions_In_Finalize}: + + +@itemize * + +@item +@code{Legacy_Heap_Finalization}: Uses the legacy automatic finalization of +heap-allocated objects + +@item +@code{Exceptions_In_Finalize}: Allow users to have a finalizer that raises exceptions +`NB!' note that using this aspect introduces execution time penalities. +@end itemize + +@node No_Raise aspect,Inference of Dependent Types in Generic Instantiations,Generalized Finalization,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions id11}@anchor{45d}@anchor{gnat_rm/gnat_language_extensions no-raise-aspect}@anchor{45c} +@subsection No_Raise aspect + + +The @code{No_Raise} aspect can be applied to a subprogram to declare that this subprogram is not +expected to raise any exceptions. Should an exception still occur during the execution of +this subpropgram, @code{Program_Error} is raised. + +@menu +* New specification for Ada.Finalization.Controlled: New specification for Ada Finalization Controlled. +* Finalized tagged types:: +* Composite types:: +* Interoperability with controlled types:: + +@end menu + +@node New specification for Ada Finalization Controlled,Finalized tagged types,,No_Raise aspect +@anchor{gnat_rm/gnat_language_extensions new-specification-for-ada-finalization-controlled}@anchor{45e} +@subsubsection New specification for @code{Ada.Finalization.Controlled} + + +@code{Ada.Finalization.Controlled} is now specified as: + +@example +type Controlled is abstract tagged null record + with Initialize => Initialize, + Adjust => Adjust, + Finalize => Finalize, + Legacy_Heap_Finalization, Exceptions_In_Finalize; + + procedure Initialize (Self : in out Controlled) is abstract; + procedure Adjust (Self : in out Controlled) is abstract; + procedure Finalize (Self : in out Controlled) is abstract; +@end example + +### Examples + +A simple example of a ref-counted type: + +@example +type T is record + Value : Integer; + Ref_Count : Natural := 0; +end record; + +procedure Inc_Ref (X : in out T); +procedure Dec_Ref (X : in out T); + +type T_Access is access all T; + +type T_Ref is record + Value : T_Access; +end record + with Adjust => Adjust, + Finalize => Finalize; + +procedure Adjust (Ref : in out T_Ref) is +begin + Inc_Ref (Ref.Value); +end Adjust; + +procedure Finalize (Ref : in out T_Ref) is +begin + Def_Ref (Ref.Value); +end Finalize; +@end example + +A simple file handle that ensures resources are properly released: + +@example +package P is + type File (<>) is limited private; + + function Open (Path : String) return File; + + procedure Close (F : in out File); +private + type File is limited record + Handle : ...; + end record + with Finalize => Close; +@end example + +@node Finalized tagged types,Composite types,New specification for Ada Finalization Controlled,No_Raise aspect +@anchor{gnat_rm/gnat_language_extensions finalized-tagged-types}@anchor{45f} +@subsubsection Finalized tagged types + + +Aspects are inherited by derived types and optionally overriden by those. The +compiler-generated calls to the user-defined operations are then +dispatching whenever it makes sense, i.e. the object in question is of +classwide type and the class includes at least one finalized-type. + +However note that for simplicity, it is forbidden to change the value of any of +those new aspects in derived types. + +@node Composite types,Interoperability with controlled types,Finalized tagged types,No_Raise aspect +@anchor{gnat_rm/gnat_language_extensions composite-types}@anchor{460} +@subsubsection Composite types + + +When a finalized type is used as a component of a composite type, the latter +becomes finalized as well. The three primitives are derived automatically +in order to call the primitives of their components. + +If that composite type was already user-finalized, then the compiler +calls the primitives of the components so as to stay consistent with today’s +controlled types’s behavior. + +So, @code{Initialize} and @code{Adjust} are called on components before they +are called on the composite object, but @code{Finalize} is called on the composite +object first. + +@node Interoperability with controlled types,,Composite types,No_Raise aspect +@anchor{gnat_rm/gnat_language_extensions interoperability-with-controlled-types}@anchor{461} +@subsubsection Interoperability with controlled types + + +As a consequence of the redefinition of the @code{Controlled} type as a base type +with the new aspects defined, interoperability with controlled type naturally +follows the definition of the above rules. In particular: + + +@itemize * + +@item +It is possible to have a new finalized type have a controlled type +component + +@item +It is possible to have a controlled type have a finalized type +component +@end itemize + +@node Inference of Dependent Types in Generic Instantiations,External_Initialization Aspect,No_Raise aspect,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions inference-of-dependent-types-in-generic-instantiations}@anchor{462} +@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 discriminants, 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 + +@node External_Initialization Aspect,,Inference of Dependent Types in Generic Instantiations,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions external-initialization-aspect}@anchor{463} +@subsection External_Initialization Aspect + + +The @code{External_Initialization} aspect provides a feature similar to Rust’s @code{include_bytes!} +and to C23’s @code{#embed}. It has the effect of initializing an object with the contents of +a file specified by a file path. + +Only string objects and objects of type @code{Ada.Streams.Stream_Element_Array} can be subject +to the @code{External_Initialization} aspect. + +Example: + +@example +with Ada.Streams; + +package P is + S : constant String with External_Initialization => "foo.txt"; + + X : constant Ada.Streams.Stream_Element_Array with External_Initialization => "bar.bin"; +end P; +@end example + +@code{External_Initialization} aspect accepts the following parameters: + + +@itemize - + +@item +mandatory @code{Path}: the path the compiler uses to access the binary resource; + +@item +optional @code{Maximum_Size}: the maximum number of bytes the compiler reads from +the resource; + +@item +optional @code{If_Empty}: an expression used in place of read data in case +the resource is empty; +@end itemize + +@code{Path} is resolved according to the same rules the compiler uses for loading the source files. + +@cartouche +@quotation Attention +The maximum size of loaded files is limited to 2@w{^31} bytes. +@end quotation +@end cartouche @node Security Hardening Features,Obsolescent Features,GNAT language extensions,Top -@anchor{gnat_rm/security_hardening_features doc}@anchor{454}@anchor{gnat_rm/security_hardening_features id1}@anchor{455}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} +@anchor{gnat_rm/security_hardening_features doc}@anchor{464}@anchor{gnat_rm/security_hardening_features id1}@anchor{465}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} @chapter Security Hardening Features @@ -29652,7 +30850,7 @@ change. @end menu @node Register Scrubbing,Stack Scrubbing,,Security Hardening Features -@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{456} +@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{466} @section Register Scrubbing @@ -29688,7 +30886,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{457} +@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{467} @section Stack Scrubbing @@ -29832,7 +31030,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{458} +@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{468} @section Hardened Conditionals @@ -29922,7 +31120,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{459} +@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{469} @section Hardened Booleans @@ -29983,7 +31181,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{45a} +@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{46a} @section Control Flow Redundancy @@ -30151,7 +31349,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{45b}@anchor{gnat_rm/obsolescent_features id1}@anchor{45c}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} +@anchor{gnat_rm/obsolescent_features doc}@anchor{46b}@anchor{gnat_rm/obsolescent_features id1}@anchor{46c}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} @chapter Obsolescent Features @@ -30170,7 +31368,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{45d}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{45e} +@anchor{gnat_rm/obsolescent_features id2}@anchor{46d}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{46e} @section pragma No_Run_Time @@ -30183,7 +31381,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{45f}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{460} +@anchor{gnat_rm/obsolescent_features id3}@anchor{46f}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{470} @section pragma Ravenscar @@ -30192,7 +31390,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{461}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{462} +@anchor{gnat_rm/obsolescent_features id4}@anchor{471}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{472} @section pragma Restricted_Run_Time @@ -30202,7 +31400,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{463}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{464} +@anchor{gnat_rm/obsolescent_features id5}@anchor{473}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{474} @section pragma Task_Info @@ -30228,7 +31426,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{465}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{466} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{475}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{476} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -30238,7 +31436,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{467}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{468} +@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{477}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{478} @chapter Compatibility and Porting Guide @@ -30260,7 +31458,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{469}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{46a} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{479}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{47a} @section Writing Portable Fixed-Point Declarations @@ -30382,7 +31580,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{46b}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{46c} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{47b}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{47c} @section Compatibility with Ada 83 @@ -30410,7 +31608,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{46d}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{46e} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{47d}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{47e} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -30510,7 +31708,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{46f}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{470} +@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{47f}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{480} @subsection More deterministic semantics @@ -30538,7 +31736,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{471}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{472} +@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{481}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{482} @subsection Changed semantics @@ -30580,7 +31778,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{473}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{474} +@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{483}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{484} @subsection Other language compatibility issues @@ -30613,7 +31811,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{475}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{476} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{485}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{486} @section Compatibility between Ada 95 and Ada 2005 @@ -30685,7 +31883,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{477}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{478} +@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{487}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{488} @section Implementation-dependent characteristics @@ -30708,7 +31906,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{479}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{47a} +@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{489}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{48a} @subsection Implementation-defined pragmas @@ -30730,7 +31928,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{47b}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{47c} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{48b}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{48c} @subsection Implementation-defined attributes @@ -30744,7 +31942,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{47d}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{47e} +@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{48d}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{48e} @subsection Libraries @@ -30773,7 +31971,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{47f}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{480} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{48f}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{490} @subsection Elaboration order @@ -30809,7 +32007,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{481}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{482} +@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{491}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{492} @subsection Target-specific aspects @@ -30822,10 +32020,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{483,,Representation Clauses}. +GNAT’s approach to these issues is described in @ref{493,,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{484}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{485} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{494}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{495} @section Compatibility with Other Ada Systems @@ -30868,7 +32066,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{486}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{483} +@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{496}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{493} @section Representation Clauses @@ -30961,7 +32159,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{487}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{488} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{497}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{498} @section Compatibility with HP Ada 83 @@ -30991,7 +32189,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{489}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{48a} +@anchor{share/gnu_free_documentation_license doc}@anchor{499}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{49a} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 0e3ee93..9ba8984 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -3,7 +3,7 @@ @setfilename gnat_ugn.info @documentencoding UTF-8 @ifinfo -@*Generated by Sphinx 5.3.0.@* +@*Generated by Sphinx 8.0.2.@* @end ifinfo @settitle GNAT User's Guide for Native Platforms @defindex ge @@ -19,7 +19,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Jul 29, 2024 +GNAT User's Guide for Native Platforms , Oct 07, 2024 AdaCore @@ -11195,7 +11195,7 @@ of the pragma @code{Restriction_Warnings}. `[warning-as-error]' Used to tag warning messages that have been converted to error messages by use of the pragma Warning_As_Error. Note that such warnings are prefixed by -the string “error: ” rather than “warning: “. +the string “error: “ rather than “warning: “. @item `[enabled by default]' @@ -11671,6 +11671,31 @@ Pre’Class, and Post’Class aspects. Also list inherited subtype predicates. This switch suppresses listing of inherited aspects. @end table +@geindex -gnatw_l (gcc) + + +@table @asis + +@item @code{-gnatw_l} + +`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. +@end table + +@geindex -gnatw_L (gcc) + + +@table @asis + +@item @code{-gnatw_L} + +`Suppress warnings on implicitly limited types.' + +This switch suppresses warnings on implicitly limited types. +@end table + @geindex -gnatwm (gcc) @@ -13456,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 * @@ -13474,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 @@ -23036,13 +23061,13 @@ From there, to be able to link your binaries with PIE and therefore drop the @code{-no-pie} workaround, you’ll need to get the identified dependencies rebuilt with PIE enabled (compiled with @code{-fPIE} and linked with @code{-pie}). -@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy-with-gnu-linux}@anchor{1c2} + @geindex SCHED_FIFO scheduling policy @geindex SCHED_RR scheduling policy @geindex SCHED_OTHER scheduling policy - +@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy-with-gnu-linux}@anchor{1c2} @node Choosing the Scheduling Policy with GNU/Linux,A GNU/Linux Debug Quirk,Position Independent Executable PIE Enabled by Default on Linux,GNU/Linux Topics @anchor{gnat_ugn/platform_specific_information id7}@anchor{1c3} @subsection Choosing the Scheduling Policy with GNU/Linux 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/gnatlink.adb b/gcc/ada/gnatlink.adb index db0fd14..e2cd196 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -1259,8 +1259,10 @@ procedure Gnatlink is Value (Libgcc_Subdir_Ptr); begin - Path (GCC_Index + 1 .. GCC_Index + Subdir'Length) - := Subdir; + Path + (GCC_Index + 1 + .. + GCC_Index + Subdir'Length) := Subdir; GCC_Index := GCC_Index + Subdir'Length; end; end if; diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index 6cf170d..ca7744b 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -83,7 +83,8 @@ package Gnatvsn is -- space to store any possible version string value for checks. This -- value should never be decreased in the future, but it would be -- OK to increase it if absolutely necessary. If it is increased, - -- be sure to increase GNAT.Compiler.Version.Ver_Len_Max as well. + -- be sure to increase GNAT.Compiler.Version.Ver_Len_Max, and to update + -- the VER_LEN_MAX define in version.c as well. Ver_Prefix : constant String := "GNAT Version: "; -- Prefix generated by binder. If it is changed, be sure to change diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 93e73f5..8019c09 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -2782,10 +2782,16 @@ __gnat_install_handler () void __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) { +#if defined(__arm__) mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; /* ARM Bump has to be an even number because of odd/even architecture. */ ((mcontext_t *) mcontext)->arm_pc += 2; +#endif + + /* Other ports, based on dwarf2 unwinding, typically leverage + kernel CFI coordinated with libgcc's explicit support for signal + frames. */ } static void @@ -2825,7 +2831,6 @@ static void __gnat_error_handler (int sig, siginfo_t *si, void *ucontext) { __gnat_adjust_context_for_raise (sig, ucontext); - __gnat_sigtramp (sig, (void *) si, (void *) ucontext, (__sigtramphandler_t *)&__gnat_map_signal); } 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/lib-util.adb b/gcc/ada/lib-util.adb index 3f0b463..6bf9d7b 100644 --- a/gcc/ada/lib-util.adb +++ b/gcc/ada/lib-util.adb @@ -271,8 +271,7 @@ package body Lib.Util is procedure Write_Info_Str (Val : String) is begin - Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length) - := Val; + Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length) := Val; Info_Buffer_Len := Info_Buffer_Len + Val'Length; Info_Buffer_Col := Info_Buffer_Col + Val'Length; end Write_Info_Str; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index fd62ef9..3820617 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -1064,6 +1064,7 @@ package Lib.Writ is procedure Add_Preprocessing_Dependency (S : Source_File_Index); -- Indicate that there is a dependency to be added on a preprocessing data - -- file or on a preprocessing definition file. + -- file, on a preprocessing definition file or on a file included through + -- External_Initialization. end Lib.Writ; diff --git a/gcc/ada/libgnarl/s-linux__android-aarch64.ads b/gcc/ada/libgnarl/s-linux__android-aarch64.ads new file mode 100644 index 0000000..4e462f2 --- /dev/null +++ b/gcc/ada/libgnarl/s-linux__android-aarch64.ads @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . L I N U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2014-2024, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- In particular, you can freely distribute your programs built with the -- +-- GNAT Pro compiler, including any required library run-time units, using -- +-- any licensing terms of your choosing. See the AdaCore Software License -- +-- for full details. -- +-- -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Android version of this package + +-- This package encapsulates cpu specific differences between implementations +-- of GNU/Linux, in order to share s-osinte-linux.ads. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package + +with Interfaces.C; +with System.Parameters; + +package System.Linux is + pragma Preelaborate; + + ---------- + -- Time -- + ---------- + + subtype long is Interfaces.C.long; + subtype suseconds_t is Interfaces.C.long; + type time_t is range -2 ** (System.Parameters.time_t_bits - 1) + .. 2 ** (System.Parameters.time_t_bits - 1) - 1; + subtype clockid_t is Interfaces.C.int; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type timeval is record + tv_sec : time_t; + tv_usec : suseconds_t; + end record; + pragma Convention (C, timeval); + + ----------- + -- Errno -- + ----------- + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 110; + + ------------- + -- Signals -- + ------------- + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 7; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 10; -- user defined signal 1 + SIGUSR2 : constant := 12; -- user defined signal 2 + SIGCLD : constant := 17; -- alias for SIGCHLD + SIGCHLD : constant := 17; -- child status change + SIGPWR : constant := 30; -- power-fail restart + SIGWINCH : constant := 28; -- window size change + SIGURG : constant := 23; -- urgent condition on IO channel + SIGPOLL : constant := 29; -- pollable event occurred + SIGIO : constant := 29; -- I/O now possible (4.2 BSD) + SIGLOST : constant := 29; -- File lock lost + SIGSTOP : constant := 19; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 20; -- user stop requested from tty + SIGCONT : constant := 18; -- stopped process has been continued + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGSYS : constant := 31; -- bad argument to system call + SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) + SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) + SIG32 : constant := 32; -- glibc internal signal + SIG33 : constant := 33; -- glibc internal signal + SIG34 : constant := 34; -- glibc internal signal + + -- struct_sigaction offsets + + -- sa_flags come first on aarch64-android (sa_flags, sa_handler, sa_mask) + + sa_flags_pos : constant := 0; + sa_handler_pos : constant := sa_flags_pos + Interfaces.C.int'Size / 8; + sa_mask_pos : constant := sa_handler_pos + Standard'Address_Size / 8; + + SA_SIGINFO : constant := 16#00000004#; + SA_ONSTACK : constant := 16#08000000#; + SA_RESTART : constant := 16#10000000#; + SA_NODEFER : constant := 16#40000000#; + +end System.Linux; diff --git a/gcc/ada/libgnarl/s-linux__android.ads b/gcc/ada/libgnarl/s-linux__android-arm.ads index ff369d5..1a21f78 100644 --- a/gcc/ada/libgnarl/s-linux__android.ads +++ b/gcc/ada/libgnarl/s-linux__android-arm.ads @@ -111,6 +111,7 @@ package System.Linux is SIGPROF : constant := 27; -- profiling timer expired SIGXCPU : constant := 24; -- CPU time limit exceeded SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGSYS : constant := 31; -- bad argument to system call SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) SIG32 : constant := 32; -- glibc internal signal diff --git a/gcc/ada/libgnarl/s-osinte__android.ads b/gcc/ada/libgnarl/s-osinte__android.ads index 8e1b5a2..ee83198 100644 --- a/gcc/ada/libgnarl/s-osinte__android.ads +++ b/gcc/ada/libgnarl/s-osinte__android.ads @@ -116,6 +116,7 @@ package System.OS_Interface is SIGPROF : constant := System.Linux.SIGPROF; SIGXCPU : constant := System.Linux.SIGXCPU; SIGXFSZ : constant := System.Linux.SIGXFSZ; + SIGSYS : constant := System.Linux.SIGSYS; SIGUNUSED : constant := System.Linux.SIGUNUSED; SIGSTKFLT : constant := System.Linux.SIGSTKFLT; @@ -175,7 +176,7 @@ package System.OS_Interface is type struct_sigaction is record sa_handler : System.Address; sa_mask : sigset_t; - sa_flags : Interfaces.C.unsigned_long; + sa_flags : Interfaces.C.int; sa_restorer : System.Address; end record; pragma Convention (C, struct_sigaction); @@ -580,16 +581,18 @@ package System.OS_Interface is private - type sigset_t is new Interfaces.C.unsigned_long; + type sigset_t is + array (0 .. OS_Constants.SIZEOF_sigset - 1) of unsigned_char; pragma Convention (C, sigset_t); for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment; pragma Warnings (Off); for struct_sigaction use record sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1; - sa_mask at Linux.sa_mask_pos range 0 .. sigset_t'Size - 1; + sa_mask at Linux.sa_mask_pos + range 0 .. OS_Constants.SIZEOF_sigset * 8 - 1; sa_flags at Linux.sa_flags_pos - range 0 .. Interfaces.C.unsigned_long'Size - 1; + range 0 .. Interfaces.C.int'Size - 1; end record; -- We intentionally leave sa_restorer unspecified and let the compiler -- append it after the last field, so disable corresponding warning. diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb deleted file mode 100644 index ff1e0d4..0000000 --- a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb +++ /dev/null @@ -1,494 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2024, AdaCore -- --- -- --- 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a DCE version of this package. --- Currently HP-UX and SNI use this file - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - -with Interfaces.C; use Interfaces.C; - -package body System.OS_Interface is - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (TS : timespec) return Duration is - begin - return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; - end To_Duration; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return timespec'(tv_sec => S, - tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int - is - Result : int; - - begin - Result := sigwait (set); - - if Result = -1 then - sig.all := 0; - return errno; - end if; - - sig.all := Signal (Result); - return 0; - end sigwait; - - -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it - - function pthread_kill (thread : pthread_t; sig : Signal) return int is - pragma Unreferenced (thread, sig); - begin - return 0; - end pthread_kill; - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - -- For all following functions, DCE Threads has a non standard behavior. - -- It sets errno but the standard Posix requires it to be returned. - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int - is - function pthread_mutexattr_create - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create"); - - begin - if pthread_mutexattr_create (attr) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutexattr_init; - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int - is - function pthread_mutexattr_delete - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete"); - - begin - if pthread_mutexattr_delete (attr) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutexattr_destroy; - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int - is - function pthread_mutex_init_base - (mutex : access pthread_mutex_t; - attr : pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init"); - - begin - if pthread_mutex_init_base (mutex, attr.all) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutex_init; - - function pthread_mutex_destroy - (mutex : access pthread_mutex_t) return int - is - function pthread_mutex_destroy_base - (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy"); - - begin - if pthread_mutex_destroy_base (mutex) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutex_destroy; - - function pthread_mutex_lock - (mutex : access pthread_mutex_t) return int - is - function pthread_mutex_lock_base - (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock"); - - begin - if pthread_mutex_lock_base (mutex) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutex_lock; - - function pthread_mutex_unlock - (mutex : access pthread_mutex_t) return int - is - function pthread_mutex_unlock_base - (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock"); - - begin - if pthread_mutex_unlock_base (mutex) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutex_unlock; - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int - is - function pthread_condattr_create - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_create, "pthread_condattr_create"); - - begin - if pthread_condattr_create (attr) /= 0 then - return errno; - else - return 0; - end if; - end pthread_condattr_init; - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int - is - function pthread_condattr_delete - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete"); - - begin - if pthread_condattr_delete (attr) /= 0 then - return errno; - else - return 0; - end if; - end pthread_condattr_destroy; - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int - is - function pthread_cond_init_base - (cond : access pthread_cond_t; - attr : pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init_base, "pthread_cond_init"); - - begin - if pthread_cond_init_base (cond, attr.all) /= 0 then - return errno; - else - return 0; - end if; - end pthread_cond_init; - - function pthread_cond_destroy - (cond : access pthread_cond_t) return int - is - function pthread_cond_destroy_base - (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy"); - - begin - if pthread_cond_destroy_base (cond) /= 0 then - return errno; - else - return 0; - end if; - end pthread_cond_destroy; - - function pthread_cond_signal - (cond : access pthread_cond_t) return int - is - function pthread_cond_signal_base - (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal"); - - begin - if pthread_cond_signal_base (cond) /= 0 then - return errno; - else - return 0; - end if; - end pthread_cond_signal; - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int - is - function pthread_cond_wait_base - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait"); - - begin - if pthread_cond_wait_base (cond, mutex) /= 0 then - return errno; - else - return 0; - end if; - end pthread_cond_wait; - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int - is - function pthread_cond_timedwait_base - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait"); - - begin - if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then - return (if errno = EAGAIN then ETIMEDOUT else errno); - else - return 0; - end if; - end pthread_cond_timedwait; - - ---------------------------- - -- POSIX.1c Section 13 -- - ---------------------------- - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int - is - function pthread_setscheduler - (thread : pthread_t; - policy : int; - priority : int) return int; - pragma Import (C, pthread_setscheduler, "pthread_setscheduler"); - - begin - if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then - return errno; - else - return 0; - end if; - end pthread_setschedparam; - - function sched_yield return int is - procedure pthread_yield; - pragma Import (C, pthread_yield, "pthread_yield"); - begin - pthread_yield; - return 0; - end sched_yield; - - ----------------------------- - -- P1003.1c - Section 16 -- - ----------------------------- - - function pthread_attr_init - (attributes : access pthread_attr_t) return int - is - function pthread_attr_create - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_create, "pthread_attr_create"); - - begin - if pthread_attr_create (attributes) /= 0 then - return errno; - else - return 0; - end if; - end pthread_attr_init; - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int - is - function pthread_attr_delete - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_delete, "pthread_attr_delete"); - - begin - if pthread_attr_delete (attributes) /= 0 then - return errno; - else - return 0; - end if; - end pthread_attr_destroy; - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int - is - function pthread_attr_setstacksize_base - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize_base, - "pthread_attr_setstacksize"); - - begin - if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then - return errno; - else - return 0; - end if; - end pthread_attr_setstacksize; - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int - is - function pthread_create_base - (thread : access pthread_t; - attributes : pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create_base, "pthread_create"); - - begin - if pthread_create_base - (thread, attributes.all, start_routine, arg) /= 0 - then - return errno; - else - return 0; - end if; - end pthread_create; - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int - is - function pthread_setspecific_base - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific_base, "pthread_setspecific"); - - begin - if pthread_setspecific_base (key, value) /= 0 then - return errno; - else - return 0; - end if; - end pthread_setspecific; - - function pthread_getspecific (key : pthread_key_t) return System.Address is - function pthread_getspecific_base - (key : pthread_key_t; - value : access System.Address) return int; - pragma Import (C, pthread_getspecific_base, "pthread_getspecific"); - Addr : aliased System.Address; - - begin - if pthread_getspecific_base (key, Addr'Access) /= 0 then - return System.Null_Address; - else - return Addr; - end if; - end pthread_getspecific; - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int - is - function pthread_keycreate - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_keycreate, "pthread_keycreate"); - - begin - if pthread_keycreate (key, destructor) /= 0 then - return errno; - else - return 0; - end if; - end pthread_key_create; - - function Get_Stack_Base (thread : pthread_t) return Address is - pragma Warnings (Off, thread); - begin - return Null_Address; - end Get_Stack_Base; - - procedure pthread_init is - begin - null; - end pthread_init; - - function intr_attach (sig : int; handler : isr_address) return long is - function c_signal (sig : int; handler : isr_address) return long; - pragma Import (C, c_signal, "signal"); - begin - return c_signal (sig, handler); - end intr_attach; - -end System.OS_Interface; diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads deleted file mode 100644 index 364a5ec..0000000 --- a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads +++ /dev/null @@ -1,487 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the HP-UX version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by the tasking run-time (libgnarl). - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Ada.Unchecked_Conversion; - -with Interfaces.C; - -with System.OS_Locks; -with System.Parameters; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lcma"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIME : constant := 52; - ETIMEDOUT : constant := 238; - - FUNC_ERR : constant := -1; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 44; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 16; -- user defined signal 1 - SIGUSR2 : constant := 17; -- user defined signal 2 - SIGCLD : constant := 18; -- alias for SIGCHLD - SIGCHLD : constant := 18; -- child status change - SIGPWR : constant := 19; -- power-fail restart - SIGVTALRM : constant := 20; -- virtual timer alarm - SIGPROF : constant := 21; -- profiling timer alarm - SIGIO : constant := 22; -- asynchronous I/O - SIGPOLL : constant := 22; -- pollable event occurred - SIGWINCH : constant := 23; -- window size change - SIGSTOP : constant := 24; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 25; -- user stop requested from tty - SIGCONT : constant := 26; -- stopped process has been continued - SIGTTIN : constant := 27; -- background tty read attempted - SIGTTOU : constant := 28; -- background tty write attempted - SIGURG : constant := 29; -- urgent condition on IO channel - SIGLOST : constant := 30; -- remote lock lost (NFS) - SIGDIL : constant := 32; -- DIL signal - SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit) - SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit) - - SIGADAABORT : constant := SIGABRT; - -- Note: on other targets, we usually use SIGABRT, but on HP/UX, it - -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM. - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := - (SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP); - - Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); - - type sigset_t is private; - - type isr_address is access procedure (sig : int); - pragma Convention (C, isr_address); - - function intr_attach (sig : int; handler : isr_address) return long; - - Intr_Attach_Reset : constant Boolean := True; - -- True if intr_attach is reset after an interrupt handler is called - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type Signal_Handler is access procedure (signo : Signal); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SA_RESTART : constant := 16#40#; - SA_SIGINFO : constant := 16#10#; - SA_ONSTACK : constant := 16#01#; - - SIG_BLOCK : constant := 0; - SIG_UNBLOCK : constant := 1; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - SIG_ERR : constant := -1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - type timespec is private; - - function nanosleep (rqtp, rmtp : access timespec) return int; - pragma Import (C, nanosleep); - - type clockid_t is new int; - - function Clock_Gettime - (Clock_Id : clockid_t; Tp : access timespec) return int; - pragma Import (C, Clock_Gettime); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 0; - SCHED_RR : constant := 1; - SCHED_OTHER : constant := 2; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - pragma Convention (C, Thread_Body); - - function Thread_Body_Access is new - Ada.Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - subtype pthread_mutex_t is System.OS_Locks.pthread_mutex_t; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - -- Read/Write lock not supported on HPUX. To add support both types - -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined - -- with the associated routines pthread_rwlock_[init/destroy] and - -- pthread_rwlock_[rdlock/wrlock/unlock]. - - subtype pthread_rwlock_t is pthread_mutex_t; - subtype pthread_rwlockattr_t is pthread_mutexattr_t; - - ----------- - -- Stack -- - ----------- - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- This is a dummy procedure to share some GNULLI files - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - pragma Inline (pthread_init); - -- This is a dummy procedure to share some GNULLI files - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait (set : access sigset_t) return int; - pragma Import (C, sigwait, "cma_sigwait"); - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Inline (sigwait); - -- DCE_THREADS has a nonstandard sigwait - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Inline (pthread_kill); - -- DCE_THREADS doesn't have pthread_kill - - function pthread_sigmask - (how : int; - set : access sigset_t; - oset : access sigset_t) return int; - -- DCE THREADS does not have pthread_sigmask. Instead, it uses sigprocmask - -- to do the signal handling when the thread library is sucked in. - pragma Import (C, pthread_sigmask, "sigprocmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - -- DCE_THREADS has a nonstandard pthread_mutexattr_init - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - -- DCE_THREADS has a nonstandard pthread_mutexattr_destroy - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - -- DCE_THREADS has a nonstandard pthread_mutex_init - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - -- DCE_THREADS has a nonstandard pthread_mutex_destroy - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_mutex_lock); - -- DCE_THREADS has nonstandard pthread_mutex_lock - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_mutex_unlock); - -- DCE_THREADS has nonstandard pthread_mutex_lock - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - -- DCE_THREADS has nonstandard pthread_condattr_init - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - -- DCE_THREADS has nonstandard pthread_condattr_destroy - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - -- DCE_THREADS has nonstandard pthread_cond_init - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - -- DCE_THREADS has nonstandard pthread_cond_destroy - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Inline (pthread_cond_signal); - -- DCE_THREADS has nonstandard pthread_cond_signal - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_cond_wait); - -- DCE_THREADS has a nonstandard pthread_cond_wait - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Inline (pthread_cond_timedwait); - -- DCE_THREADS has a nonstandard pthread_cond_timedwait - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Inline (pthread_setschedparam); - -- DCE_THREADS has a nonstandard pthread_setschedparam - - function sched_yield return int; - pragma Inline (sched_yield); - -- DCE_THREADS has a nonstandard sched_yield - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Inline (pthread_attr_init); - -- DCE_THREADS has a nonstandard pthread_attr_init - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Inline (pthread_attr_destroy); - -- DCE_THREADS has a nonstandard pthread_attr_destroy - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Inline (pthread_attr_setstacksize); - -- DCE_THREADS has a nonstandard pthread_attr_setstacksize - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Inline (pthread_create); - -- DCE_THREADS has a nonstandard pthread_create - - procedure pthread_detach (thread : access pthread_t); - pragma Import (C, pthread_detach); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Inline (pthread_setspecific); - -- DCE_THREADS has a nonstandard pthread_setspecific - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Inline (pthread_getspecific); - -- DCE_THREADS has a nonstandard pthread_getspecific - - type destructor_pointer is access procedure (arg : System.Address); - pragma Convention (C, destructor_pointer); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Inline (pthread_key_create); - -- DCE_THREADS has a nonstandard pthread_key_create - -private - - type array_type_1 is array (Integer range 0 .. 7) of unsigned_long; - type sigset_t is record - X_X_sigbits : array_type_1; - end record; - pragma Convention (C, sigset_t); - - type pid_t is new int; - - type time_t is range -2 ** (System.Parameters.time_t_bits - 1) - .. 2 ** (System.Parameters.time_t_bits - 1) - 1; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - CLOCK_REALTIME : constant clockid_t := 1; - - type cma_t_address is new System.Address; - - type cma_t_handle is record - field1 : cma_t_address; - field2 : Short_Integer; - field3 : Short_Integer; - end record; - for cma_t_handle'Size use 64; - - type pthread_attr_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_attr_t); - - type pthread_condattr_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_condattr_t); - - type pthread_mutexattr_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_mutexattr_t); - - type pthread_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_t); - - type pthread_cond_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_cond_t); - - type pthread_key_t is new int; - -end System.OS_Interface; diff --git a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb deleted file mode 100644 index 7f4e707..0000000 --- a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb +++ /dev/null @@ -1,1210 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2024, Free Software Foundation, Inc. -- --- -- --- GNARL 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a HP-UX DCE threads (HPUX 10) version of this package - --- This package contains all the GNULL primitives that interface directly with --- the underlying OS. - -with Ada.Unchecked_Conversion; - -with Interfaces.C; - -with System.Interrupt_Management; -with System.OS_Constants; -with System.OS_Primitives; -with System.Task_Primitives.Interrupt_Operations; -with System.Tasking.Debug; - -pragma Warnings (Off); -with System.Interrupt_Management.Operations; -pragma Elaborate_All (System.Interrupt_Management.Operations); -pragma Warnings (On); - -with System.Soft_Links; --- We use System.Soft_Links instead of System.Tasking.Initialization --- because the later is a higher level package that we shouldn't depend on. --- For example when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Stages. - -package body System.Task_Primitives.Operations is - - package OSC renames System.OS_Constants; - package SSL renames System.Soft_Links; - - use Interfaces.C; - - use System.OS_Interface; - use System.OS_Locks; - use System.OS_Primitives; - use System.Parameters; - use System.Tasking; - use System.Tasking.Debug; - - package PIO renames System.Task_Primitives.Interrupt_Operations; - - ---------------- - -- Local Data -- - ---------------- - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used to protect All_Tasks_List - - Environment_Task_Id : Task_Id; - -- A variable to hold Task_Id for the environment task - - Unblocked_Signal_Mask : aliased sigset_t; - -- The set of signals that should unblocked in all tasks - - Time_Slice_Val : constant Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Dispatching_Policy : constant Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - -- Note: the reason that Locking_Policy is not needed is that this - -- is not implemented for DCE threads. The HPUX 10 port is at this - -- stage considered dead, and no further work is planned on it. - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads) - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_Id); - pragma Inline (Initialize); - -- Initialize various data needed by this package - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does the executing thread have a TCB? - - procedure Set (Self_Id : Task_Id); - pragma Inline (Set); - -- Set the self id for the current task - - function Self return Task_Id; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific - - ---------------------------------- - -- ATCB allocation/deallocation -- - ---------------------------------- - - package body ATCB_Allocation is separate; - -- The body of this package is shared across several targets - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_Id is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Abort_Handler (Sig : Signal); - - function To_Address is - new Ada.Unchecked_Conversion (Task_Id, System.Address); - - ------------------- - -- Abort_Handler -- - ------------------- - - procedure Abort_Handler (Sig : Signal) is - pragma Unreferenced (Sig); - - Self_Id : constant Task_Id := Self; - Result : Interfaces.C.int; - Old_Set : aliased sigset_t; - - begin - if Self_Id.Deferral_Level = 0 - and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level - and then not Self_Id.Aborting - then - Self_Id.Aborting := True; - - -- Make sure signals used for RTS internal purpose are unmasked - - Result := - pthread_sigmask - (SIG_UNBLOCK, - Unblocked_Signal_Mask'Access, - Old_Set'Access); - pragma Assert (Result = 0); - - raise Standard'Abort_Signal; - end if; - end Abort_Handler; - - ----------------- - -- Stack_Guard -- - ----------------- - - -- The underlying thread system sets a guard page at the bottom of a thread - -- stack, so nothing is needed. - -- ??? Check the comment above - - procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is - pragma Unreferenced (T, On); - begin - null; - end Stack_Guard; - - ------------------- - -- Get_Thread_Id -- - ------------------- - - function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_Id renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are initialized - -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such - -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any - -- status change of RTS. Therefore raising Storage_Error in the following - -- routines should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : not null access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - L.Priority := Prio; - - Result := pthread_mutex_init (L.L'Access, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - procedure Initialize_Lock - (L : not null access RTS_Lock; - Level : Lock_Level) - is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : not null access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L.L'Access); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : not null access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock - (L : not null access Lock; - Ceiling_Violation : out Boolean) - is - Result : Interfaces.C.int; - - begin - L.Owner_Priority := Get_Priority (Self); - - if L.Priority < L.Owner_Priority then - Ceiling_Violation := True; - return; - end if; - - Result := pthread_mutex_lock (L.L'Access); - pragma Assert (Result = 0); - Ceiling_Violation := False; - end Write_Lock; - - procedure Write_Lock (L : not null access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end Write_Lock; - - procedure Write_Lock (T : Task_Id) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock - (L : not null access Lock; - Ceiling_Violation : out Boolean) - is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : not null access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock (L : not null access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock (T : Task_Id) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end Unlock; - - ----------------- - -- Set_Ceiling -- - ----------------- - - -- Dynamic priority ceilings are not supported by the underlying system - - procedure Set_Ceiling - (L : not null access Lock; - Prio : System.Any_Priority) - is - pragma Unreferenced (L, Prio); - begin - null; - end Set_Ceiling; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_Id; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - - Result : Interfaces.C.int; - - begin - Result := - pthread_cond_wait - (cond => Self_ID.Common.LL.CV'Access, - mutex => Self_ID.Common.LL.L'Access); - - -- EINTR is not considered a failure - - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - procedure Timed_Sleep - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - Timedout := True; - Yielded := False; - - Abs_Time := - (if Mode = Relative - then Duration'Min (Time, Max_Sensible_Delay) + Check_Time - else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - Result := - pthread_cond_timedwait - (cond => Self_ID.Common.LL.CV'Access, - mutex => Self_ID.Common.LL.L'Access, - abstime => Request'Access); - - exit when Abs_Time <= Monotonic_Clock; - - if Result = 0 or Result = EINTR then - - -- Somebody may have called Wakeup for us - - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIMEDOUT); - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - - Result : Interfaces.C.int; - pragma Warnings (Off, Result); - - begin - Write_Lock (Self_ID); - - Abs_Time := - (if Mode = Relative - then Time + Check_Time - else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - Self_ID.Common.State := Delay_Sleep; - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - Result := - pthread_cond_timedwait - (cond => Self_ID.Common.LL.CV'Access, - mutex => Self_ID.Common.LL.L'Access, - abstime => Request'Access); - - exit when Abs_Time <= Monotonic_Clock; - - pragma Assert (Result = 0 or else - Result = ETIMEDOUT or else - Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - Result := sched_yield; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - TS : aliased timespec; - Result : Interfaces.C.int; - begin - Result := Clock_Gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); - pragma Assert (Result = 0); - return To_Duration (TS); - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 10#1.0#E-6; - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - pragma Unreferenced (Result); - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - type Prio_Array_Type is array (System.Any_Priority) of Integer; - pragma Atomic_Components (Prio_Array_Type); - - Prio_Array : Prio_Array_Type; - -- Global array containing the id of the currently running task for - -- each priority. - -- - -- Note: assume we are on single processor with run-til-blocked scheduling - - procedure Set_Priority - (T : Task_Id; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - Result : Interfaces.C.int; - Array_Item : Integer; - Param : aliased struct_sched_param; - - function Get_Policy (Prio : System.Any_Priority) return Character; - pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); - -- Get priority specific dispatching policy - - Priority_Specific_Policy : constant Character := Get_Policy (Prio); - -- Upper case first character of the policy name corresponding to the - -- task as set by a Priority_Specific_Dispatching pragma. - - begin - Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); - - if Dispatching_Policy = 'R' - or else Priority_Specific_Policy = 'R' - or else Time_Slice_Val > 0 - then - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - - elsif Dispatching_Policy = 'F' - or else Priority_Specific_Policy = 'F' - or else Time_Slice_Val = 0 - then - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - - else - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); - end if; - - pragma Assert (Result = 0); - - if Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' then - - -- Annex D requirement [RM D.2.2 par. 9]: - -- If the task drops its priority due to the loss of inherited - -- priority, it is added at the head of the ready queue for its - -- new active priority. - - if Loss_Of_Inheritance - and then Prio < T.Common.Current_Priority - then - Array_Item := Prio_Array (T.Common.Base_Priority) + 1; - Prio_Array (T.Common.Base_Priority) := Array_Item; - - loop - -- Let some processes a chance to arrive - - Yield; - - -- Then wait for our turn to proceed - - exit when Array_Item = Prio_Array (T.Common.Base_Priority) - or else Prio_Array (T.Common.Base_Priority) = 1; - end loop; - - Prio_Array (T.Common.Base_Priority) := - Prio_Array (T.Common.Base_Priority) - 1; - end if; - end if; - - T.Common.Current_Priority := Prio; - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_Id) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_Id) is - begin - Self_ID.Common.LL.Thread := pthread_self; - Specific.Set (Self_ID); - end Enter_Task; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_Id is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (pthread_self); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := - pthread_mutex_init - (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := - pthread_cond_init - (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - else - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_Id; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Result : Interfaces.C.int; - - function Thread_Body_Access is new - Ada.Unchecked_Conversion (System.Address, Thread_Body); - - begin - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setstacksize - (Attributes'Access, Interfaces.C.size_t (Stack_Size)); - pragma Assert (Result = 0); - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - pragma Assert (Result = 0 or else Result = EAGAIN); - - Succeeded := Result = 0; - - pthread_detach (T.Common.LL.Thread'Access); - -- Detach the thread using pthread_detach, since DCE threads do not have - -- pthread_attr_set_detachstate. - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - Set_Priority (T, Priority); - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - - begin - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - ATCB_Allocation.Free_ATCB (T); - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - Specific.Set (null); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_Id) is - begin - -- Interrupt Server_Tasks may be waiting on an "event" flag (signal) - - if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then - System.Interrupt_Management.Operations.Interrupt_Self_Process - (PIO.Get_Interrupt_ID (T)); - end if; - end Abort_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - Result : Interfaces.C.int; - begin - -- Initialize internal state (always to False (ARM D.10(6))) - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - -- Initialize internal condition variable - - Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - if Result = ENOMEM then - raise Storage_Error; - end if; - end if; - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - -- Destroy internal mutex - - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Destroy internal condition variable - - Result := pthread_cond_destroy (S.CV'Access); - pragma Assert (Result = 0); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - S.State := False; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves - -- the state to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := pthread_cond_signal (S.CV'Access); - pragma Assert (Result = 0); - - else - S.State := True; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - if S.Waiting then - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (ARM D.10 par. 10). - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - - raise Program_Error; - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). - - if S.State then - S.State := False; - else - S.Waiting := True; - - loop - -- Loop in case pthread_cond_wait returns earlier than expected - -- (e.g. in case of EINTR caused by a signal). - - Result := pthread_cond_wait (S.CV'Access, S.L'Access); - pragma Assert (Result = 0 or else Result = EINTR); - - exit when not S.Waiting; - end loop; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end if; - end Suspend_Until_True; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_Id) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_Id is - begin - return Environment_Task_Id; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_Id; - Thread_Self : Thread_Id) return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_Id; - Thread_Self : Thread_Id) return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - begin - return False; - end Resume_Task; - - -------------------- - -- Stop_All_Tasks -- - -------------------- - - procedure Stop_All_Tasks is - begin - null; - end Stop_All_Tasks; - - --------------- - -- Stop_Task -- - --------------- - - function Stop_Task (T : ST.Task_Id) return Boolean is - pragma Unreferenced (T); - begin - return False; - end Stop_Task; - - ------------------- - -- Continue_Task -- - ------------------- - - function Continue_Task (T : ST.Task_Id) return Boolean is - pragma Unreferenced (T); - begin - return False; - end Continue_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_Id) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; - - function State - (Int : System.Interrupt_Management.Interrupt_ID) return Character; - pragma Import (C, State, "__gnat_get_interrupt_state"); - -- Get interrupt state. Defined in a-init.c. The input argument is - -- the interrupt number, and the result is one of the following: - - Default : constant Character := 's'; - -- 'n' this interrupt not set by any Interrupt_State pragma - -- 'u' Interrupt_State pragma set state to User - -- 'r' Interrupt_State pragma set state to Runtime - -- 's' Interrupt_State pragma set state to System (use "default" - -- system handler) - - begin - Environment_Task_Id := Environment_Task; - - Interrupt_Management.Initialize; - - -- Initialize the lock used to synchronize chain of all ATCBs - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Specific.Initialize (Environment_Task); - - -- Make environment task known here because it doesn't go through - -- Activate_Tasks, which does it for all other tasks. - - Known_Tasks (Known_Tasks'First) := Environment_Task; - Environment_Task.Known_Tasks_Index := Known_Tasks'First; - - Enter_Task (Environment_Task); - - -- Install the abort-signal handler - - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default - then - act.sa_flags := 0; - act.sa_handler := Abort_Handler'Address; - - Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0); - act.sa_mask := Tmp_Set; - - Result := - sigaction ( - Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end if; - end Initialize; - - -- NOTE: Unlike other pthread implementations, we do *not* mask all - -- signals here since we handle signals using the process-wide primitive - -- signal, rather than using sigthreadmask and sigwait. The reason of - -- this difference is that sigwait doesn't work when some critical - -- signals (SIGABRT, SIGPIPE) are masked. - - ----------------------- - -- Set_Task_Affinity -- - ----------------------- - - procedure Set_Task_Affinity (T : ST.Task_Id) is - pragma Unreferenced (T); - - begin - -- Setting task affinity is not supported by the underlying system - - null; - end Set_Task_Affinity; - -end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads deleted file mode 100644 index 9ec5dcb..0000000 --- a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2024, Free Software Foundation, Inc. -- --- -- --- GNARL 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a HP-UX version of this package - --- This package provides low-level support for most tasking features - -with System.OS_Interface; -with System.OS_Locks; - -package System.Task_Primitives is - pragma Preelaborate; - - type Lock is limited private; - -- Should be used for implementation of protected objects - - type Suspension_Object is limited private; - -- Should be used for the implementation of Ada.Synchronous_Task_Control - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - - type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task basis. - -- A component of this type is guaranteed to be included in the - -- Ada_Task_Control_Block. - - subtype Task_Address is System.Address; - Task_Address_Size : constant := Standard'Address_Size; - -- Type used for task addresses and its size - - Alternate_Stack_Size : constant := 0; - -- No alternate signal stack is used on this platform - -private - type Lock is record - L : aliased System.OS_Locks.RTS_Lock; - Priority : Integer; - Owner_Priority : Integer; - end record; - - type Suspension_Object is record - State : Boolean; - pragma Atomic (State); - -- Boolean that indicates whether the object is open. This field is - -- marked Atomic to ensure that we can read its value without locking - -- the access to the Suspension_Object. - - Waiting : Boolean; - -- Flag showing if there is a task already suspended on this object - - L : aliased System.OS_Locks.RTS_Lock; - -- Protection for ensuring mutual exclusion on the Suspension_Object - - CV : aliased System.OS_Interface.pthread_cond_t; - -- Condition variable used to queue threads until condition is signaled - end record; - - type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; - -- pragma Atomic (Thread); - -- Unfortunately, the above fails because Thread is 64 bits. - - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the - -- same value (thr_self value). We do not want to use lock on those - -- operations and the only thing we have to make sure is that they - -- are updated in atomic fashion. - - CV : aliased System.OS_Interface.pthread_cond_t; - -- Condition variable used to queue threads until condition is signaled - - L : aliased System.OS_Locks.RTS_Lock; - -- Protection for all components is lock L - end record; - -end System.Task_Primitives; diff --git a/gcc/ada/libgnat/a-coinho__shared.ads b/gcc/ada/libgnat/a-coinho__shared.ads index ddab1fd..57abd1b 100644 --- a/gcc/ada/libgnat/a-coinho__shared.ads +++ b/gcc/ada/libgnat/a-coinho__shared.ads @@ -109,7 +109,7 @@ private type Holder_Access is access all Holder; - type Shared_Holder is record + type Shared_Holder is limited record Counter : System.Atomic_Counters.Atomic_Counter; Element : Element_Access; end record; diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb index fef79f6..8dafe93 100644 --- a/gcc/ada/libgnat/a-except.adb +++ b/gcc/ada/libgnat/a-except.adb @@ -1768,8 +1768,8 @@ package body Ada.Exceptions is Exception_Propagation.Propagate_Exception (X); else declare - Excep : constant EOA - := Exception_Propagation.Allocate_Occurrence; + Excep : constant EOA := + Exception_Propagation.Allocate_Occurrence; Saved_MO : constant System.Address := Excep.Machine_Occurrence; begin Save_Occurrence (Excep.all, X); diff --git a/gcc/ada/libgnat/a-exexpr.adb b/gcc/ada/libgnat/a-exexpr.adb index 4ef68c5..0fe5227 100644 --- a/gcc/ada/libgnat/a-exexpr.adb +++ b/gcc/ada/libgnat/a-exexpr.adb @@ -494,8 +494,8 @@ package body Exception_Propagation is then declare Current : constant EOA := Get_Current_Excep.all; - Cur_Occ : constant GCC_Exception_Access - := To_GCC_Exception (Current.Machine_Occurrence); + Cur_Occ : constant GCC_Exception_Access := + To_GCC_Exception (Current.Machine_Occurrence); begin -- If we are releasing the Machine_Occurrence of the current -- exception, reset the access to it, so that it is no diff --git a/gcc/ada/libgnat/a-ngcoar.adb b/gcc/ada/libgnat/a-ngcoar.adb index 4c9c0ad..6a10283 100644 --- a/gcc/ada/libgnat/a-ngcoar.adb +++ b/gcc/ada/libgnat/a-ngcoar.adb @@ -1105,8 +1105,8 @@ package body Ada.Numerics.Generic_Complex_Arrays is declare Row : constant Integer := Vectors'First (2) + (K - 1); begin - Vectors (Row, Col) - := (Vecs (J * 2, Col), Vecs (J * 2, Col + N)); + Vectors (Row, Col) := + (Vecs (J * 2, Col), Vecs (J * 2, Col + N)); end; end loop; end; diff --git a/gcc/ada/libgnat/g-awk.adb b/gcc/ada/libgnat/g-awk.adb index 62856d9..c928494 100644 --- a/gcc/ada/libgnat/g-awk.adb +++ b/gcc/ada/libgnat/g-awk.adb @@ -261,7 +261,7 @@ package body GNAT.AWK is -- Session Data -- ------------------ - type Session_Data is record + type Session_Data is limited record Current_File : Text_IO.File_Type; Current_Line : Unbounded_String; Separators : Split.Mode_Access; diff --git a/gcc/ada/libgnat/g-comlin.ads b/gcc/ada/libgnat/g-comlin.ads index c20cd5e..2a131e5 100644 --- a/gcc/ada/libgnat/g-comlin.ads +++ b/gcc/ada/libgnat/g-comlin.ads @@ -1045,7 +1045,7 @@ private type Depth is range 1 .. Max_Depth; - type Level is record + type Level is limited record Name_Last : Natural := 0; Dir : GNAT.Directory_Operations.Dir_Type; end record; @@ -1087,7 +1087,7 @@ private -- separators in the pattern. end record; - type Opt_Parser_Data (Arg_Count : Natural) is record + type Opt_Parser_Data (Arg_Count : Natural) is limited record Arguments : GNAT.OS_Lib.Argument_List_Access; -- null if reading from the command line 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-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb index 46a7d61..028a55d 100644 --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -1753,6 +1753,7 @@ package body System.Dwarf_Lines is Success : Boolean; Done : Boolean; S : Object_Symbol; + Closest_S : Object_Symbol := Null_Symbol; begin -- Initialize result @@ -1801,7 +1802,22 @@ package body System.Dwarf_Lines is else S := First_Symbol (C.Obj.all); while S /= Null_Symbol loop - if Spans (S, Addr_Int) then + if Format (C.Obj.all) = PECOFF + or else Format (C.Obj.all) = PECOFF_PLUS + then + -- Don't use the size of symbols from PECOFF files; it's + -- just a guess and can be unreliable. Instead, iterate + -- over the entire symbol table and use the symbol with the + -- highest address lower than Addr_Int. + + if Closest_S = Null_Symbol + or else (Closest_S.Value < S.Value + and then S.Value <= Addr_Int) + then + Closest_S := S; + end if; + + elsif Spans (S, Addr_Int) then Subprg_Name := Object_Reader.Name (C.Obj.all, S); exit; end if; @@ -1809,6 +1825,14 @@ package body System.Dwarf_Lines is S := Next_Symbol (C.Obj.all, S); end loop; + if (Format (C.Obj.all) = PECOFF + or else Format (C.Obj.all) = PECOFF_PLUS) + and then Closest_S /= Null_Symbol + then + S := Closest_S; -- for consistency with non-PECOFF + Subprg_Name := Object_Reader.Name (C.Obj.all, S); + end if; + -- Search address in aranges table Aranges_Lookup (C, Addr, Info_Offset, Success); diff --git a/gcc/ada/libgnat/s-excmac__arm.ads b/gcc/ada/libgnat/s-excmac__arm.ads index 23d02f8..463191d 100644 --- a/gcc/ada/libgnat/s-excmac__arm.ads +++ b/gcc/ada/libgnat/s-excmac__arm.ads @@ -154,7 +154,7 @@ package System.Exceptions.Machine is -- A GNAT exception object to be dealt with by the personality routine -- called by the GCC unwinding runtime. - type GNAT_GCC_Exception is record + type GNAT_GCC_Exception is limited record Header : Unwind_Control_Block; -- ABI Exception header first diff --git a/gcc/ada/libgnat/s-excmac__gcc.ads b/gcc/ada/libgnat/s-excmac__gcc.ads index 2489905..6cbc926 100644 --- a/gcc/ada/libgnat/s-excmac__gcc.ads +++ b/gcc/ada/libgnat/s-excmac__gcc.ads @@ -142,7 +142,7 @@ package System.Exceptions.Machine is -- A GNAT exception object to be dealt with by the personality routine -- called by the GCC unwinding runtime. - type GNAT_GCC_Exception is record + type GNAT_GCC_Exception is limited record Header : Unwind_Exception; -- ABI Exception header first 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/libgnat/s-oslock__hpux-dce.ads b/gcc/ada/libgnat/s-oslock__hpux-dce.ads deleted file mode 100644 index 824c395..0000000 --- a/gcc/ada/libgnat/s-oslock__hpux-dce.ads +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ L O C K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the HP-UX version of this package - -with Interfaces.C; -with System.OS_Constants; - -package System.OS_Locks is - pragma Preelaborate; - - type pthread_mutex_t is limited private; - - subtype RTS_Lock is pthread_mutex_t; - -- Should be used inside the runtime system. The difference between Lock - -- and the RTS_Lock is that the latter serves only as a semaphore so that - -- we do not check for ceiling violations. - -private - - type cma_t_address is new System.Address; - - type cma_t_handle is record - field1 : cma_t_address; - field2 : Short_Integer; - field3 : Short_Integer; - end record; - for cma_t_handle'Size use 64; - - type pthread_mutex_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_mutex_t); - -end System.OS_Locks; diff --git a/gcc/ada/libgnat/s-rannum.adb b/gcc/ada/libgnat/s-rannum.adb index 2f2fd66..14dbc0d 100644 --- a/gcc/ada/libgnat/s-rannum.adb +++ b/gcc/ada/libgnat/s-rannum.adb @@ -108,8 +108,8 @@ is Lower_Mask : constant := 2**31 - 1; Upper_Mask : constant := 2**31; - Matrix_A : constant array (State_Val range 0 .. 1) of State_Val - := [0, 16#9908b0df#]; + Matrix_A : constant array (State_Val range 0 .. 1) of State_Val := + [0, 16#9908b0df#]; -- The twist transformation is represented by a matrix of the form -- -- [ 0 I(31) ] @@ -280,11 +280,11 @@ is 2#01000# => 0, 2#01001# => 1, 2#01010# => 0, 2#01011# => 2, 2#01100# => 0, 2#01101# => 1, 2#01110# => 0, 2#01111# => 4]; - Pow_Tab : constant array (Bit_Count range 0 .. 3) of Real - := [0 => 2.0**(0 - T'Machine_Mantissa), - 1 => 2.0**(-1 - T'Machine_Mantissa), - 2 => 2.0**(-2 - T'Machine_Mantissa), - 3 => 2.0**(-3 - T'Machine_Mantissa)]; + Pow_Tab : constant array (Bit_Count range 0 .. 3) of Real := + [0 => 2.0**(0 - T'Machine_Mantissa), + 1 => 2.0**(-1 - T'Machine_Mantissa), + 2 => 2.0**(-2 - T'Machine_Mantissa), + 3 => 2.0**(-3 - T'Machine_Mantissa)]; Extra_Bits : constant Natural := (Unsigned'Size - T'Machine_Mantissa + 1); diff --git a/gcc/ada/libgnat/s-soflin.ads b/gcc/ada/libgnat/s-soflin.ads index c2d9475..61025e5 100644 --- a/gcc/ada/libgnat/s-soflin.ads +++ b/gcc/ada/libgnat/s-soflin.ads @@ -339,7 +339,7 @@ package System.Soft_Links is -- specific data. This type is used to store the necessary data into the -- Task_Control_Block or into a global variable in the non tasking case. - type TSD is record + type TSD is limited record Pri_Stack_Info : aliased Stack_Checking.Stack_Info; -- Information on stack (Base/Limit/Size) used by System.Stack_Checking. -- If this TSD does not belong to the environment task, the Size field diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb index 64ff9a2..6182316 100644 --- a/gcc/ada/libgnat/s-trasym__dwarf.adb +++ b/gcc/ada/libgnat/s-trasym__dwarf.adb @@ -357,16 +357,16 @@ package body System.Traceback.Symbolic is -- fail opening that downstream, we'll just bail out. declare - Argv0 : constant System.Address - := Conv.To_Pointer (Gnat_Argv) (0); + Argv0 : constant System.Address := + Conv.To_Pointer (Gnat_Argv) (0); - Resolved_Argv0 : constant System.Address - := locate_exec_on_path (Argv0); + Resolved_Argv0 : constant System.Address := + locate_exec_on_path (Argv0); - Exe_Argv : constant System.Address - := (if Resolved_Argv0 /= System.Null_Address - then Resolved_Argv0 - else Argv0); + Exe_Argv : constant System.Address := + (if Resolved_Argv0 /= System.Null_Address + then Resolved_Argv0 + else Argv0); Result : constant String := Value (Exe_Argv); @@ -637,14 +637,24 @@ package body System.Traceback.Symbolic is -- Symbolic_Traceback -- ------------------------ + LDAD_Header : constant String := "Load address: "; + -- Copied from Ada.Exceptions.Exception_Data + function Symbolic_Traceback (Traceback : Tracebacks_Array; Suppress_Hex : Boolean) return String is - Res : Bounded_String (Max_Length => Max_String_Length); + Load_Address : constant Address := Get_Executable_Load_Address; + Res : Bounded_String (Max_Length => Max_String_Length); + begin System.Soft_Links.Lock_Task.all; Init_Exec_Module; + if Load_Address /= Null_Address then + Append (Res, LDAD_Header); + Append_Address (Res, Load_Address); + Append (Res, ASCII.LF); + end if; Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res); System.Soft_Links.Unlock_Task.all; diff --git a/gcc/ada/libgnat/s-vaen16.ads b/gcc/ada/libgnat/s-vaen16.ads index 5ac8beb..7cc98be 100644 --- a/gcc/ada/libgnat/s-vaen16.ads +++ b/gcc/ada/libgnat/s-vaen16.ads @@ -45,6 +45,7 @@ package System.Val_Enum_16 is Indexes : System.Address; Hash : Impl.Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Natural renames Impl.Value_Enumeration; @@ -54,6 +55,7 @@ package System.Val_Enum_16 is Indexes : System.Address; Hash : Impl.Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Boolean renames Impl.Valid_Value_Enumeration; diff --git a/gcc/ada/libgnat/s-vaen32.ads b/gcc/ada/libgnat/s-vaen32.ads index ee540f1..0900d18 100644 --- a/gcc/ada/libgnat/s-vaen32.ads +++ b/gcc/ada/libgnat/s-vaen32.ads @@ -45,6 +45,7 @@ package System.Val_Enum_32 is Indexes : System.Address; Hash : Impl.Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Natural renames Impl.Value_Enumeration; @@ -54,6 +55,7 @@ package System.Val_Enum_32 is Indexes : System.Address; Hash : Impl.Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Boolean renames Impl.Valid_Value_Enumeration; diff --git a/gcc/ada/libgnat/s-vaenu8.ads b/gcc/ada/libgnat/s-vaenu8.ads index 6d34533..62e9fa3 100644 --- a/gcc/ada/libgnat/s-vaenu8.ads +++ b/gcc/ada/libgnat/s-vaenu8.ads @@ -45,6 +45,7 @@ package System.Val_Enum_8 is Indexes : System.Address; Hash : Impl.Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Natural renames Impl.Value_Enumeration; @@ -54,6 +55,7 @@ package System.Val_Enum_8 is Indexes : System.Address; Hash : Impl.Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Boolean renames Impl.Valid_Value_Enumeration; diff --git a/gcc/ada/libgnat/s-valboo.adb b/gcc/ada/libgnat/s-valboo.adb index 5cb3b98..f7a13ba 100644 --- a/gcc/ada/libgnat/s-valboo.adb +++ b/gcc/ada/libgnat/s-valboo.adb @@ -53,7 +53,7 @@ is S : String (Str'Range) := Str; begin - Normalize_String (S, F, L); + Normalize_String (S, F, L, To_Upper_Case => True); pragma Assert (F = System.Val_Spec.First_Non_Space_Ghost (S, Str'First, Str'Last)); diff --git a/gcc/ada/libgnat/s-valcha.adb b/gcc/ada/libgnat/s-valcha.adb index 46f3eb4..13cbcb5 100644 --- a/gcc/ada/libgnat/s-valcha.adb +++ b/gcc/ada/libgnat/s-valcha.adb @@ -43,7 +43,9 @@ package body System.Val_Char is S : String (Str'Range) := Str; begin - Normalize_String (S, F, L); + -- The names of control characters use upper case letters + + Normalize_String (S, F, L, To_Upper_Case => True); -- Accept any single character enclosed in quotes diff --git a/gcc/ada/libgnat/s-valuen.adb b/gcc/ada/libgnat/s-valuen.adb index caf4fc6..8fa4c26 100644 --- a/gcc/ada/libgnat/s-valuen.adb +++ b/gcc/ada/libgnat/s-valuen.adb @@ -40,6 +40,7 @@ package body System.Value_N is Indexes : System.Address; Hash : Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Integer with Pure_Function; -- Same as Value_Enumeration, except returns negative if Value_Enumeration @@ -54,6 +55,7 @@ package body System.Value_N is Indexes : System.Address; Hash : Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Integer is @@ -76,7 +78,7 @@ package body System.Value_N is pragma Assert (Num + 1 in IndexesT'Range); begin - Normalize_String (S, F, L); + Normalize_String (S, F, L, To_Upper_Case => not Is_Wide); declare Normal : String renames S (F .. L); @@ -120,11 +122,13 @@ package body System.Value_N is Indexes : System.Address; Hash : Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Boolean is begin - return Value_Enumeration_Pos (Names, Indexes, Hash, Num, Str) >= 0; + return + Value_Enumeration_Pos (Names, Indexes, Hash, Num, Is_Wide, Str) >= 0; end Valid_Value_Enumeration; ----------------------- @@ -136,11 +140,12 @@ package body System.Value_N is Indexes : System.Address; Hash : Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Natural is Result : constant Integer := - Value_Enumeration_Pos (Names, Indexes, Hash, Num, Str); + Value_Enumeration_Pos (Names, Indexes, Hash, Num, Is_Wide, Str); begin -- The comparison eliminates the need for a range check on return diff --git a/gcc/ada/libgnat/s-valuen.ads b/gcc/ada/libgnat/s-valuen.ads index 83ffd71..fe2babf 100644 --- a/gcc/ada/libgnat/s-valuen.ads +++ b/gcc/ada/libgnat/s-valuen.ads @@ -47,6 +47,7 @@ package System.Value_N is Indexes : System.Address; Hash : Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Natural with Inline; -- Used to compute Enum'Value (Str) where Enum is some enumeration type @@ -60,7 +61,8 @@ package System.Value_N is -- The parameter Hash is a (perfect) hash function for Names and Indexes. -- The parameter Num is the value N - 1 (i.e. Enum'Pos (Enum'Last)). -- The reason that Indexes is passed by address is that the actual type - -- is created on the fly by the expander. + -- is created on the fly by the expander. The parameter Is_Wide is True + -- if the original attribute was [Wide_]Wide_Value. -- -- Str is the argument of the attribute function, and may have leading -- and trailing spaces, and letters can be upper or lower case or mixed. @@ -72,6 +74,7 @@ package System.Value_N is Indexes : System.Address; Hash : Hash_Function_Ptr; Num : Natural; + Is_Wide : Boolean; Str : String) return Boolean with Inline; -- Returns True if Str is a valid Image of some enumeration literal, False diff --git a/gcc/ada/libgnat/s-valuti.adb b/gcc/ada/libgnat/s-valuti.adb index 147a10a..50e7f6a 100644 --- a/gcc/ada/libgnat/s-valuti.adb +++ b/gcc/ada/libgnat/s-valuti.adb @@ -67,8 +67,9 @@ is ---------------------- procedure Normalize_String - (S : in out String; - F, L : out Integer) + (S : in out String; + F, L : out Integer; + To_Upper_Case : Boolean) is begin F := S'First; @@ -106,9 +107,9 @@ is L := L - 1; end loop; - -- Except in the case of a character literal, convert to upper case + -- Convert to upper case if requested and not a character literal - if S (F) /= ''' then + if To_Upper_Case and then S (F) /= ''' then for J in F .. L loop S (J) := To_Upper (S (J)); pragma Loop_Invariant diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads index 70585477..cc804f4 100644 --- a/gcc/ada/libgnat/s-valuti.ads +++ b/gcc/ada/libgnat/s-valuti.ads @@ -60,8 +60,9 @@ is -- Raises constraint error with message: bad input for 'Value: "xxx" procedure Normalize_String - (S : in out String; - F, L : out Integer) + (S : in out String; + F, L : out Integer; + To_Upper_Case : Boolean) with Post => (if Sp.Only_Space_Ghost (S'Old, S'First, S'Last) then F > L @@ -76,7 +77,7 @@ is (if L < S'Last then Sp.Only_Space_Ghost (S'Old, L + 1, S'Last)) and then - (if S'Old (F) /= ''' then + (if To_Upper_Case and then S'Old (F) /= ''' then (for all J in S'Range => (if J in F .. L then S (J) = System.Case_Util.To_Upper (S'Old (J)) @@ -84,9 +85,10 @@ is S (J) = S'Old (J))))); -- This procedure scans the string S setting F to be the index of the first -- non-blank character of S and L to be the index of the last non-blank - -- character of S. Any lower case characters present in S will be folded to - -- their upper case equivalent except for character literals. If S consists - -- of entirely blanks (including when S = "") then we return with F > L. + -- character of S. If To_Upper_Case is True and S does not represent a + -- character literal, then any lower case characters in S are changed to + -- their upper case counterparts. If S consists of only blank characters + -- (including when S = "") then we return with F > L. procedure Scan_Sign (Str : String; diff --git a/gcc/ada/libgnat/s-valwch.adb b/gcc/ada/libgnat/s-valwch.adb index e452e31..4162bc1 100644 --- a/gcc/ada/libgnat/s-valwch.adb +++ b/gcc/ada/libgnat/s-valwch.adb @@ -67,7 +67,7 @@ package body System.Val_WChar is S : String (Str'Range) := Str; begin - Normalize_String (S, F, L); + Normalize_String (S, F, L, To_Upper_Case => False); -- Character literal case diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 34e3bf6..72f6c20 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -1520,6 +1520,17 @@ package body Namet is return Buf.Chars (1 .. Buf.Length); end To_String; + ---------------------- + -- Unlock_If_Locked -- + ---------------------- + + procedure Unlock_If_Locked is + begin + if Name_Chars.Locked then + Unlock; + end if; + end Unlock_If_Locked; + ------------ -- Unlock -- ------------ diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index d3990cb..ab304ad 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -423,6 +423,9 @@ package Namet is -- Unlocks the name table to allow use of the extra space reserved by the -- call to Lock. See gnat1drv for details of the need for this. + procedure Unlock_If_Locked; + -- If the name table is locked, calls Unlock. Otherwise, does nothing. + procedure Write_Name (Id : Valid_Name_Id); -- Write_Name writes the characters of the specified name using the -- standard output procedures in package Output. The name is written 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/osint.adb b/gcc/ada/osint.adb index 046480b..fd70c51 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -2350,10 +2350,10 @@ package body Osint is begin -- Construct a C compatible character string buffer - Buffer (1 .. Search_Dir_Prefix.all'Length) - := Search_Dir_Prefix.all; - Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1) - := Search_File.all; + Buffer (1 .. Search_Dir_Prefix.all'Length) := + Search_Dir_Prefix.all; + Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1) := + Search_File.all; Buffer (Buffer'Last) := ASCII.NUL; File_FD := Open_Read (Buffer'Address, Binary); diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb index 8b51fc7..d935b58 100644 --- a/gcc/ada/par-ch11.adb +++ b/gcc/ada/par-ch11.adb @@ -61,8 +61,7 @@ package body Ch11 is Handled_Stmt_Seq_Node := New_Node (N_Handled_Sequence_Of_Statements, Token_Ptr); Set_Statements - (Handled_Stmt_Seq_Node, - P_Sequence_Of_Statements (SS_Extm_Sreq, Handled => True)); + (Handled_Stmt_Seq_Node, P_Sequence_Of_Statements (SS_Extm_Sreq)); if Token = Tok_Exception then Scan; -- past EXCEPTION diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index a5f4319..04246dc 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -3841,7 +3841,7 @@ package body Ch3 is -- end if; Set_Subtype_Indication (CompDef_Node, Empty); - Set_Aliased_Present (CompDef_Node, False); + Set_Aliased_Present (CompDef_Node, Aliased_Present); Set_Access_Definition (CompDef_Node, P_Access_Definition (Not_Null_Present)); else diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 8b491c2..e76b0d8 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -218,6 +218,8 @@ package body Ch4 is Arg_List : List_Id := No_List; -- kill junk warning Attr_Name : Name_Id := No_Name; -- kill junk warning + Error_Loc : Source_Ptr; + begin -- Case of not a name @@ -889,13 +891,16 @@ package body Ch4 is ("positional parameter association " & "not allowed after named one"); + Error_Loc := Token_Ptr; + Expr_Node := P_Expression_If_OK; -- Leaving the '>' in an association is not unusual, so suggest -- a possible fix. if Nkind (Expr_Node) = N_Op_Eq then - Error_Msg_N ("\maybe `='>` was intended", Expr_Node); + Error_Msg_Sloc := Sloc (Expr_Node); + Error_Msg ("\maybe `='>` was intended #", Error_Loc); end if; -- We go back to scanning out expressions, so that we do not get diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index a245fa1..557aaf1 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -23,10 +23,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Style_Checks (All_Checks); --- Turn off subprogram body ordering check. Subprograms are in order by RM --- section rather than alphabetical. - with Sinfo.CN; use Sinfo.CN; separate (Par) @@ -135,8 +131,7 @@ package body Ch5 is -- parsing a statement, then the scan pointer is advanced past the next -- semicolon and the parse continues. - function P_Sequence_Of_Statements - (SS_Flags : SS_Rec; Handled : Boolean := False) return List_Id + function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is Statement_Required : Boolean := SS_Flags.Sreq; -- This flag indicates if a subsequent statement (other than a pragma) @@ -221,32 +216,57 @@ package body Ch5 is -- Start of processing for P_Sequence_Of_Statements begin - -- In Ada 2022, we allow declarative items to be mixed with - -- statements. The loop below alternates between calling - -- P_Declarative_Items to parse zero or more declarative items, - -- and parsing a statement. + -- When extensions are active, we allow declarative items to be mixed + -- with statements. The loop below alternates between calling + -- P_Declarative_Items to parse zero or more declarative items, and + -- parsing a statement. loop Ignore (Tok_Semicolon); declare Num_Statements : constant Nat := List_Length (Statement_List); + Decl : Node_Id; begin P_Declarative_Items (Statement_List, Declare_Expression => False, In_Spec => False, In_Statements => True); -- Use the length of the list to determine whether we parsed - -- any declarative items. If so, it's an error unless language - -- extensions are enabled. + -- any declarative items. if List_Length (Statement_List) > Num_Statements then + Decl := Pick (Statement_List, Num_Statements + 1); + + -- If so, it's an error unless language extensions are enabled. + if All_Errors_Mode or else No (Decl_Loc) then - Decl_Loc := Sloc (Pick (Statement_List, Num_Statements + 1)); + Decl_Loc := Sloc (Decl); Error_Msg_GNAT_Extension - ("declarations mixed with statements", - Sloc (Pick (Statement_List, Num_Statements + 1))); + ("declarations mixed with statements", Sloc (Decl), + Is_Core_Extension => True); + + end if; + + -- Check every declaration added to the list, to see whether + -- it's part of the allowed subset of declarations. Only check + -- that if core extensions are allowed. + + if Core_Extensions_Allowed then + while Present (Decl) loop + if not (Nkind (Decl) in + N_Object_Declaration | N_Object_Renaming_Declaration | + N_Use_Type_Clause | N_Use_Package_Clause | + N_Representation_Clause) + then + Error_Msg + ("Declaration kind not allowed in statements lists", + Sloc (Decl)); + end if; + + Next (Decl); + end loop; end if; end if; end; @@ -937,12 +957,9 @@ package body Ch5 is exit when SS_Flags.Unco; end loop; - -- If there are no declarative items in the list, or if the list is part - -- of a handled sequence of statements, we just return the list. - -- Otherwise, we wrap the list in a block statement, so the declarations - -- will have a proper scope. In the Handled case, it would be wrong to - -- wrap, because we want the code before and after "begin" to be in the - -- same scope. Example: + -- If there are declarative items in the list, we always wrap it in a + -- block, so that anything declared in a statement list is not visible + -- from the exception handlers. Example: -- -- if ... then -- use Some_Package; @@ -958,17 +975,25 @@ package body Ch5 is -- end; -- end if; -- - -- But we don't wrap this: + -- This: -- -- declare -- X : Integer; -- begin -- X : Integer; -- - -- Otherwise, we would fail to detect the error (conflicting X's). - -- Similarly, if a representation clause appears in the statement - -- part, we don't want it to appear more nested than the declarative - -- part -- that would cause an unwanted error. + -- is transformed into this: + -- + -- declare + -- X : Integer; + -- begin + -- declare + -- X : Integer; + -- begin + -- ... + -- + -- We hence don't try to detect this case, even though it can be + -- confusing to users, and might possibly deserve a warning. if Present (Decl_Loc) then -- Forbid labels and declarative items from coexisting. Otherwise, @@ -983,47 +1008,17 @@ package body Ch5 is Error_Msg ("label in same list as declarative item", Label_Loc); end if; - -- Forbid exception handlers and declarative items from - -- coexisting. Example: - -- - -- X : Integer := 123; - -- procedure P is - -- begin - -- X : Integer := 456; - -- exception - -- when Cain => - -- Put(X); - -- end P; - -- - -- It was proposed that in the handler, X should refer to the outer - -- X, but that's just confusing. - - if Token = Tok_Exception then - Error_Msg - ("declarative item in statements conflicts with " & - "exception handler below", - Decl_Loc); - Error_Msg - ("exception handler conflicts with " & - "declarative item in statements above", - Token_Ptr); - end if; - - if Handled then - return Statement_List; - else - declare - Loc : constant Source_Ptr := Sloc (First (Statement_List)); - Block : constant Node_Id := - Make_Block_Statement - (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements - (Loc, Statements => Statement_List)); - begin - return New_List (Block); - end; - end if; + declare + Loc : constant Source_Ptr := Sloc (First (Statement_List)); + Block : constant Node_Id := + Make_Block_Statement + (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements + (Loc, Statements => Statement_List)); + begin + return New_List (Block); + end; else return Statement_List; end if; 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/par-prag.adb b/gcc/ada/par-prag.adb index 181b0d4..8b953b3 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -590,6 +590,12 @@ begin when Pragma_Source_File_Name | Pragma_Source_File_Name_Project => + if Debug_Flag_Underscore_MM then + -- -gnatd_M is causes the compiler to ignore source file name + -- pragmas. It's used for reduced reproducer generation. + return Pragma_Node; + end if; + Source_File_Name : declare Unam : Unit_Name_Type; Expr1 : Node_Id; @@ -1442,6 +1448,7 @@ begin | Pragma_Fast_Math | Pragma_Favor_Top_Level | Pragma_Finalize_Storage_Only + | Pragma_First_Controlling_Parameter | Pragma_Ghost | Pragma_Global | Pragma_GNAT_Annotate @@ -1555,6 +1562,7 @@ begin | Pragma_Short_Circuit_And_Or | Pragma_Short_Descriptors | Pragma_Simple_Storage_Pool_Type + | Pragma_Simulate_Internal_Error | Pragma_Static_Elaboration_Desired | Pragma_Storage_Size | Pragma_Storage_Unit diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 9d502b2..0df0c67 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -886,7 +886,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- Used in loop constructs and quantified expressions. function P_Sequence_Of_Statements - (SS_Flags : SS_Rec; Handled : Boolean := False) return List_Id; + (SS_Flags : SS_Rec) return List_Id; -- SS_Flags indicates the acceptable termination tokens; see body for -- details. Handled is true if we are parsing a handled sequence of -- statements. diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb index 6d30511..fbf0e59 100644 --- a/gcc/ada/pprint.adb +++ b/gcc/ada/pprint.adb @@ -653,6 +653,7 @@ package body Pprint is when N_Case_Expression | N_Delta_Aggregate + | N_External_Initializer | N_Interpolated_String_Literal | N_Op_Rotate_Left | N_Op_Rotate_Right diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index bda35d8..2e3cdde 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -1262,7 +1262,7 @@ package body Restrict is -- Set as warning if warning case if Restriction_Warnings (R) then - Add_Str ("??"); + Add_Str ("?*?"); end if; -- Set main message diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 4cfd9fe..2c1a1ee 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -1187,8 +1187,8 @@ package body Rtsfind is else Save_Private_Visibility; declare - Saved_Instance_Context : constant Instance_Context.Context - := Instance_Context.Save_And_Reset; + Saved_Instance_Context : constant Instance_Context.Context := + Instance_Context.Save_And_Reset; begin Semantics (Cunit (U.Unum)); Instance_Context.Restore (Saved_Instance_Context); 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/scng.adb b/gcc/ada/scng.adb index 08ce2ab..658970f 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -2135,14 +2135,19 @@ package body Scng is -- Lower case letters when 'a' .. 'z' => - if Core_Extensions_Allowed - and then Source (Scan_Ptr) = 'f' + if Source (Scan_Ptr) = 'f' and then Source (Scan_Ptr + 1) = '"' then - Scan_Ptr := Scan_Ptr + 1; - Accumulate_Checksum (Source (Scan_Ptr)); - Token := Tok_Left_Interpolated_String; - return; + if Core_Extensions_Allowed then + Scan_Ptr := Scan_Ptr + 1; + Accumulate_Checksum (Source (Scan_Ptr)); + Token := Tok_Left_Interpolated_String; + return; + else + Error_Msg_GNAT_Extension + ("interpolated string", Scan_Ptr, + Is_Core_Extension => True); + end if; end if; Name_Len := 1; @@ -2155,15 +2160,20 @@ package body Scng is -- Upper case letters when 'A' .. 'Z' => - if Core_Extensions_Allowed - and then Source (Scan_Ptr) = 'F' + if Source (Scan_Ptr) = 'F' and then Source (Scan_Ptr + 1) = '"' then - Error_Msg_S - ("delimiter of interpolated string must be in lowercase"); - Scan_Ptr := Scan_Ptr + 1; - Token := Tok_Left_Interpolated_String; - return; + if Core_Extensions_Allowed then + Error_Msg_S + ("delimiter of interpolated string must be in lowercase"); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Left_Interpolated_String; + return; + else + Error_Msg_GNAT_Extension + ("interpolated string", Scan_Ptr, + Is_Core_Extension => True); + end if; end if; Token_Contains_Uppercase := True; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 3305b56..915a1cc 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -249,6 +249,12 @@ package body Sem is when N_Extension_Aggregate => Analyze_Aggregate (N); + -- The expansion of the External_Initialization aspect creates fully + -- analyzed N_External_Initializer nodes. + + when N_External_Initializer => + null; + when N_Formal_Object_Declaration => Analyze_Formal_Object_Declaration (N); diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 087e324..63e17f4 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -26,6 +26,8 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; +with Diagnostics.Constructors; use Diagnostics.Constructors; with Einfo; use Einfo; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; @@ -301,7 +303,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 +316,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 +1598,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 +1972,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 +2042,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 +2142,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 +2215,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); @@ -2542,6 +2553,66 @@ package body Sem_Aggr is null; elsif Present (Component_Associations (N)) then + Assoc := First (Component_Associations (N)); + + -- Loop over associations to identify any iterated associations that + -- need to be converted from the form with a Defining_Identifer and + -- Discrete_Choices list to the form with an Iterator_Specification. + + if Nkind (Assoc) = N_Iterated_Component_Association then + while Present (Assoc) loop + if Nkind (Assoc) = N_Iterated_Component_Association + and then No (Iterator_Specification (Assoc)) + then + declare + Choice : constant Node_Id := + First (Discrete_Choices (Assoc)); + Copy : Node_Id; + begin + + -- A copy of Choice is made before it's analyzed, + -- to preserve prefixed calls in their original form, + -- because otherwise the analysis of Choice can transform + -- such calls to normal form, and the later analysis of + -- the iterator_specification created below may trigger + -- an error on the call (in the case where the function + -- is not directly visible). + + Copy := Copy_Separate_Tree (Choice); + + -- This is an association with a Defining_Identifier and + -- Discrete_Choice_List, but if the latter has a single + -- choice denoting an object (including a function call) + -- of an iterator type, then it's a stand-in for an + -- Iterator_Specification, and so we transform the + -- association accordingly. + + if No (Next (Choice)) then + Analyze (Choice); + + if Is_Object_Reference (Choice) + and then Is_Iterator (Etype (Choice)) + then + Set_Iterator_Specification + (Assoc, + Make_Iterator_Specification (Sloc (N), + Defining_Identifier => + Relocate_Node (Defining_Identifier (Assoc)), + Name => Copy, + Reverse_Present => Reverse_Present (Assoc), + Iterator_Filter => Empty, + Subtype_Indication => Empty)); + + Set_Defining_Identifier (Assoc, Empty); + Set_Discrete_Choices (Assoc, No_List); + end if; + end if; + end; + end if; + + Next (Assoc); + end loop; + end if; -- Verify that all or none of the component associations -- include an iterator specification. @@ -2550,6 +2621,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); @@ -2871,16 +2950,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) @@ -3646,6 +3784,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; @@ -3814,7 +3956,7 @@ package body Sem_Aggr is then null; - elsif Nkind (Choice) = N_Function_Call then + elsif Is_Object_Reference (Choice) then declare I_Spec : constant Node_Id := Make_Iterator_Specification (Sloc (N), @@ -3911,6 +4053,21 @@ package body Sem_Aggr is Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, New_Indexed_Subp, Assign_Indexed_Subp); + if Present (First (Expressions (N))) + and then Present (First (Component_Associations (N))) + then + if Debug_Flag_Underscore_DD then + Record_Mixed_Container_Aggregate_Error + (Aggr => N, + Pos_Elem => First (Expressions (N)), + Named_Elem => First (Component_Associations (N))); + else + Error_Msg_N + ("container aggregate cannot be both positional and named", N); + end if; + return; + end if; + if Present (Add_Unnamed_Subp) and then No (New_Indexed_Subp) and then Present (Etype (Add_Unnamed_Subp)) @@ -4044,14 +4201,6 @@ package body Sem_Aggr is if Present (Component_Associations (N)) and then not Is_Empty_List (Component_Associations (N)) then - if Present (Expressions (N)) - and then not Is_Empty_List (Expressions (N)) - then - Error_Msg_N ("container aggregate cannot be " - & "both positional and named", N); - return; - end if; - Comp := First (Component_Associations (N)); while Present (Comp) loop diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 994a45b..9ab1972 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -11231,7 +11231,38 @@ package body Sem_Attr is -- If attribute was universal type, reset to actual type if Is_Universal_Numeric_Type (Etype (N)) then - Set_Etype (N, Typ); + + -- If evaluating N might yield a value that that does not satisfy + -- the constraints of the subtype Typ, then we need to set the + -- Etype of N to "Base_Type (Typ)" instead of "Typ". + -- Otherwise we can end up incorrectly assuming that the value + -- belongs to the subtype and, as a result, eliminating required + -- runtime checks. + -- Rather than trying to analyze the expression and the subtype to + -- test for this case, it seems better to take the simpler approach; + -- that is, to ignore this opportunity for an insignificant + -- micro-optimization and to instead call Base_Type unconditionally. + -- But that doesn't work; it turns out that there is a corner case + -- where (for reasons that are not completely understood) we need + -- to set the Etype to Typ for reasons of correctness. See below + -- for description of this case. + + if Attr_Id = Attribute_Pos + and then not Comes_From_Source (N) + then + -- This case occurs when indexing into a packed array and + -- the index type is an enumeration type that is subject to + -- an enumeration representation specification. + -- See the "Analyze_And_Resolve (Expr_Copy, Standard_Natural);" + -- statement in exp_pakd.adb . + -- For reasons that are not understood, we see a regression test + -- failure if we don't handle that case by calling Set_Etype here + -- with "Typ" instead of "Base_Type (Typ)"). + + Set_Etype (N, Typ); + else + Set_Etype (N, Base_Type (Typ)); + end if; end if; -- A Ghost attribute must appear in a specific context diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 9903a2b..5edf667 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -1118,12 +1118,12 @@ package body Sem_Aux is elsif Is_Private_Type (Btype) then - -- If Ent occurs in the completion of a limited private type, then - -- look for the word "limited" in the full view. + -- If Ent occurs in the completion of a private type, then + -- look for the word "limited" in the full view. if Nkind (Parent (Ent)) = N_Full_Type_Declaration - and then Nkind (Type_Definition (Parent (Ent))) = - N_Record_Definition + and then Nkind (Type_Definition (Parent (Ent))) in + N_Record_Definition | N_Derived_Type_Definition and then Limited_Present (Type_Definition (Parent (Ent))) then return True; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 267cdaa..9d19787 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -1550,8 +1550,8 @@ package body Sem_Case is return Result; end Component_Bounds_Info; - Component_Bounds : constant Composite_Range_Info - := Component_Bounds_Info; + Component_Bounds : constant Composite_Range_Info := + Component_Bounds_Info; package Case_Bindings is @@ -2517,8 +2517,8 @@ package body Sem_Case is use Uint_Sets; - Result : constant Representative_Values_Array - := (others => Uint_Sets.Create (Initial_Size => 32)); + Result : constant Representative_Values_Array := + (others => Uint_Sets.Create (Initial_Size => 32)); procedure Insert_Representative (Value : Uint; P : Part_Id); -- Insert the given Value into the representative values set @@ -2563,8 +2563,8 @@ package body Sem_Case is return Result; end Representative_Values_Init; - Representative_Values : constant Representative_Values_Array - := Representative_Values_Init; + Representative_Values : constant Representative_Values_Array := + Representative_Values_Init; -- We want to avoid looking at every point in the Cartesian -- product of all component values. Instead we select, for each -- component, a set of representative values and then look only @@ -2664,8 +2664,8 @@ package body Sem_Case is return Equal; else declare - Intersection : constant Value_Index_Set - := Indexed (S1) and Indexed (S2); + Intersection : constant Value_Index_Set := + Indexed (S1) and Indexed (S2); begin if (for all Flag of Intersection => not Flag) then return Disjoint; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index bc0d34e..33f6f18 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2295,7 +2295,7 @@ package body Sem_Ch12 is procedure Abandon_Instantiation (N : Node_Id) is begin - Error_Msg_N ("\instantiation abandoned!", N); + Error_Msg_N ("instantiation abandoned!", N); raise Instantiation_Error; end Abandon_Instantiation; @@ -7337,8 +7337,12 @@ package body Sem_Ch12 is then -- If the formal is a tagged type the corresponding class-wide -- type has been generated as well, and it must be skipped. + -- Likewise, for a formal discrete type, the base type has been + -- generated as well (see Analyze_Formal_Discrete_Type). - if Is_Type (E2) and then Is_Tagged_Type (E2) then + if Is_Type (E2) + and then (Is_Tagged_Type (E2) or else Is_Enumeration_Type (E2)) + then Next_Entity (E2); end if; @@ -7736,15 +7740,15 @@ package body Sem_Ch12 is (Instance : Entity_Id; Is_Formal_Box : Boolean) is - Gen_Id : constant Entity_Id - := (if Is_Generic_Unit (Instance) then - Instance - elsif Is_Wrapper_Package (Instance) then - Generic_Parent - (Specification - (Unit_Declaration_Node (Related_Instance (Instance)))) - else - Generic_Parent (Package_Specification (Instance))); + Gen_Id : constant Entity_Id := + (if Is_Generic_Unit (Instance) then + Instance + elsif Is_Wrapper_Package (Instance) then + Generic_Parent + (Specification + (Unit_Declaration_Node (Related_Instance (Instance)))) + else + Generic_Parent (Package_Specification (Instance))); -- The generic unit Parent_Scope : constant Entity_Id := Scope (Gen_Id); @@ -14952,6 +14956,18 @@ package body Sem_Ch12 is then Error_Msg_NE ("actual for & must be a tagged type", Actual, Gen_T); + + -- For generic formal tagged types with the First_Controlling_Param + -- aspect, ensure that the actual type also has this aspect. + + elsif Is_Tagged_Type (Act_T) + and then Is_Tagged_Type (A_Gen_T) + and then not Has_First_Controlling_Parameter_Aspect (Act_T) + and then Has_First_Controlling_Parameter_Aspect (A_Gen_T) + then + Error_Msg_NE + ("actual for & must be a 'First_'Controlling_'Parameter tagged " + & "type", Actual, Gen_T); end if; Validate_Discriminated_Formal_Type; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 3fb0209..953da67 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; @@ -1247,7 +1248,7 @@ package body Sem_Ch13 is if Etype (Expression (ASN)) = Any_Type then Error_Msg_NE - ("\aspect must be fully defined before & is frozen", + ("aspect must be fully defined before & is frozen", ASN, E); end if; @@ -1982,6 +1983,11 @@ package body Sem_Ch13 is Error_Msg_N ("aspect must apply to a type with discriminants", Expr); + elsif not Is_First_Subtype (E) then + Error_Msg_N + ("aspect not specifiable in a subtype declaration", + Aspect); + elsif not Is_Entity_Name (Expr) then Error_Msg_N ("aspect must name a discriminant of current type", Expr); @@ -4512,6 +4518,63 @@ package body Sem_Ch13 is Pragma_Name => Nam); end if; + -- Minimum check of First_Controlling_Parameter aspect; + -- the checks shared by the aspect and its corresponding + -- pragma are performed when the pragma is analyzed. + + if A_Id = Aspect_First_Controlling_Parameter then + if Present (Expr) then + Analyze (Expr); + end if; + + 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; + + if not (Is_Type (E) + and then + (Is_Tagged_Type (E) + or else Is_Concurrent_Type (E))) + then + Error_Msg_N + ("aspect 'First_'Controlling_'Parameter can only " + & "apply to tagged type or concurrent type", + Aspect); + goto Continue; + end if; + + if Present (Expr) + and then Entity (Expr) = Standard_False + then + -- 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, + -- we take note to avoid checking for its implicit + -- inheritance (see Analyze_Full_Type_Declaration). + + Set_Has_First_Controlling_Parameter_Aspect (E); + end if; + -- In general cases, the corresponding pragma/attribute -- definition clause will be inserted later at the freezing -- point, and we do not need to build it now. @@ -4575,6 +4638,20 @@ package body Sem_Ch13 is Chars => Name_Storage_Size, Expression => Relocate_Node (Expr)); end if; + + when Aspect_External_Initialization => + Error_Msg_GNAT_Extension + ("External_Initialization aspect", Sloc (Aspect)); + + -- The External_Initialization aspect specifications that + -- are attached to object declarations were already + -- processed and detached from the list at an earlier stage, + -- so we can only get here if the specification is not in an + -- appropriate place. + + Error_Msg_N + ("External_Initialization aspect can only be specified " & + "for object declarations", Aspect); end case; -- Attach the corresponding pragma/attribute definition clause to @@ -5703,13 +5780,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; @@ -11498,6 +11580,7 @@ package body Sem_Ch13 is | Aspect_Dimension | Aspect_Dimension_System | Aspect_Exceptional_Cases + | Aspect_External_Initialization | Aspect_Global | Aspect_GNAT_Annotate | Aspect_Implicit_Dereference @@ -13931,8 +14014,8 @@ package body Sem_Ch13 is (E : Entity_Id; Nam : Name_Id) return Node_Id is - Rep : constant Node_Id - := Get_Rep_Item (E, Nam, Check_Parents => True); + Rep : constant Node_Id := + Get_Rep_Item (E, Nam, Check_Parents => True); begin if Present (Rep) and then not Has_Rep_Item (E, Nam, Check_Parents => False) @@ -13948,8 +14031,8 @@ package body Sem_Ch13 is Nam1 : Name_Id; Nam2 : Name_Id) return Node_Id is - Rep : constant Node_Id - := Get_Rep_Item (E, Nam1, Nam2, Check_Parents => True); + Rep : constant Node_Id := + Get_Rep_Item (E, Nam1, Nam2, Check_Parents => True); begin if Present (Rep) and then not Has_Rep_Item (E, Nam1, Nam2, Check_Parents => False) @@ -15465,20 +15548,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 @@ -15512,14 +15616,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; @@ -16364,8 +16460,8 @@ package body Sem_Ch13 is end if; declare - Set : constant Local_Restriction_Set - := Parse_Aspect_Local_Restrictions (Parent (N)); + Set : constant Local_Restriction_Set := + Parse_Aspect_Local_Restrictions (Parent (N)); pragma Unreferenced (Set); begin null; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ce3fe18..ea0a97b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -47,6 +47,7 @@ with Ghost; use Ghost; with Itypes; use Itypes; with Layout; use Layout; with Lib; use Lib; +with Lib.Writ; with Lib.Xref; use Lib.Xref; with Mutably_Tagged; use Mutably_Tagged; with Namet; use Namet; @@ -82,7 +83,9 @@ with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Sinput; use Sinput; +with Sinput.L; with Snames; use Snames; +with Stringt; with Strub; use Strub; with Targparm; use Targparm; with Tbuild; use Tbuild; @@ -741,6 +744,11 @@ package body Sem_Ch3 is -- Check that an entity in a list of progenitors is an interface, -- emit error otherwise. + procedure Warn_On_Inherently_Limited_Type (E : Entity_Id); + -- Emit a warning if a record type that does not have a limited keyword in + -- its definition has any components that are limited (which implicitly + -- make the type limited). + ----------------------- -- Access_Definition -- ----------------------- @@ -3510,6 +3518,46 @@ package body Sem_Ch3 is then Check_Restriction (No_Local_Tagged_Types, T); end if; + + -- Derived tagged types inherit aspect First_Controlling_Parameter + -- from their parent type and also from implemented interface types. + -- We implicitly perform inheritance here and will check for the + -- explicit confirming pragma or aspect in the sources when this type + -- is frozen (required for pragmas since they are placed at any place + -- after the type declaration; otherwise, when the pragma is used after + -- some non-first-controlling-parameter primitive, the reported errors + -- and warning would differ when the pragma is used). + + if Is_Tagged_Type (T) + and then Is_Derived_Type (T) + and then not Has_First_Controlling_Parameter_Aspect (T) + then + pragma Assert (Etype (T) /= T); + + if Has_First_Controlling_Parameter_Aspect (Etype (T)) then + Set_Has_First_Controlling_Parameter_Aspect (T); + + elsif Present (Interfaces (T)) + and then not Is_Empty_Elmt_List (Interfaces (T)) + then + declare + Elmt : Elmt_Id := First_Elmt (Interfaces (T)); + Iface : Entity_Id; + + begin + while Present (Elmt) loop + Iface := Node (Elmt); + + if Has_First_Controlling_Parameter_Aspect (Iface) then + Set_Has_First_Controlling_Parameter_Aspect (T); + exit; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + end if; end Analyze_Full_Type_Declaration; ---------------------------------- @@ -3800,6 +3848,12 @@ package body Sem_Ch3 is -- E is set to Expression (N) throughout this routine. When Expression -- (N) is modified, E is changed accordingly. + procedure Apply_External_Initialization + (Specification : N_Aspect_Specification_Id); + -- Transform N with the effects of the External_Initialization aspect + -- specified by Specification. Note that Specification is removed from + -- N's list of aspects. + procedure Check_Dynamic_Object (Typ : Entity_Id); -- A library-level object with nonstatic discriminant constraints may -- require dynamic allocation. The declaration is illegal if the @@ -3836,6 +3890,86 @@ package body Sem_Ch3 is -- Any other relevant delayed aspects on object declarations ??? + ----------------------------------- + -- Apply_External_Initialization -- + ----------------------------------- + + procedure Apply_External_Initialization + (Specification : N_Aspect_Specification_Id) + is + Def : constant Node_Id := Expression (Specification); + + Expr : N_Subexpr_Id; + + begin + Remove (Specification); + + Error_Msg_GNAT_Extension + ("External_Initialization aspect", Sloc (Specification)); + + if Present (E) then + Error_Msg_N + ("initialization expression not allowed for object with aspect " + & "External_Initialization", Specification); + return; + end if; + + Set_Has_Init_Expression (N); + Set_Expression (N, Error); + E := Error; + + if Nkind (Def) /= N_String_Literal then + Error_Msg_N + ("External_Initialization aspect expects a string literal value", + Specification); + return; + end if; + + if not (Is_String_Type (T) + or else Is_RTE (Base_Type (T), RE_Stream_Element_Array)) + then + Error_Msg_N + ("External_Initialization aspect can only be applied to objects " + & "of string types or type Ada.Streams.Stream_Element_Array", + Specification); + return; + end if; + + begin + declare + Name : constant Valid_Name_Id := + Stringt.String_To_Name (Strval (Def)); + + Source_File_I : constant Source_File_Index := + Sinput.L.Load_Source_File (File_Name_Type (Name)); + begin + if Source_File_I <= No_Source_File then + Error_Msg_N ("cannot find input file", Specification); + return; + end if; + + Lib.Writ.Add_Preprocessing_Dependency (Source_File_I); + + Expr := + Make_External_Initializer + (Sloc (Specification), Source_File_I); + end; + exception + when Constraint_Error => + -- The most likely cause for a constraint error is a file + -- whose size does not fit into Integer. We could modify + -- Load_Source_File to report that error with a special + -- exception??? + Error_Msg_N + ("External_Initialization file exceeds maximum length", + Specification); + return; + end; + + Set_Expression (N, Expr); + E := Expr; + end Apply_External_Initialization; + -------------------------- -- Check_Dynamic_Object -- -------------------------- @@ -4348,6 +4482,15 @@ package body Sem_Ch3 is end if; end if; + declare + S : constant Opt_N_Aspect_Specification_Id := + Find_Aspect (Id, Aspect_External_Initialization); + begin + if Present (S) then + Apply_External_Initialization (S); + end if; + end; + -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry -- out some static checks. @@ -4846,12 +4989,10 @@ package body Sem_Ch3 is end if; end if; - -- Case of initialization present but in error. Set initial - -- expression as absent (but do not make above complaints). + -- Case of initialization present but in error elsif E = Error then - Set_Expression (N, Empty); - E := Empty; + null; -- Case of initialization present @@ -13113,10 +13254,10 @@ package body Sem_Ch3 is and then Present (Underlying_Full_View (Full_Base)) then declare - Underlying_Full_Base : constant Entity_Id - := Underlying_Full_View (Full_Base); - Underlying_Full : constant Entity_Id - := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); + Underlying_Full_Base : constant Entity_Id := + Underlying_Full_View (Full_Base); + Underlying_Full : constant Entity_Id := + Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); begin Set_Is_Itype (Underlying_Full); Set_Associated_Node_For_Itype (Underlying_Full, Related_Nod); @@ -17818,8 +17959,8 @@ package body Sem_Ch3 is -- to the backend since we don't know the true size of -- anything at this point. - Insert_After_And_Analyze (N, - Make_CW_Size_Compile_Check (T, Root_Class_Typ)); + Append_Freeze_Actions (T, + New_List (Make_CW_Size_Compile_Check (T, Root_Class_Typ))); end if; end if; end; @@ -21870,6 +22011,14 @@ package body Sem_Ch3 is end; end if; + -- Propagate First_Controlling_Parameter aspect to the full type + + if Is_Tagged_Type (Priv_T) + and then Has_First_Controlling_Parameter_Aspect (Priv_T) + then + Set_Has_First_Controlling_Parameter_Aspect (Full_T); + end if; + -- Propagate predicates to full type, and predicate function if already -- defined. It is not clear that this can actually happen? the partial -- view cannot be frozen yet, and the predicate function has not been @@ -22876,6 +23025,8 @@ package body Sem_Ch3 is Derive_Progenitor_Subprograms (T, T); end if; + Warn_On_Inherently_Limited_Type (T); + Check_Function_Writable_Actuals (N); end Record_Type_Declaration; @@ -23348,4 +23499,31 @@ package body Sem_Ch3 is Set_Is_Constrained (T); end Signed_Integer_Type_Declaration; + ------------------------------------- + -- Warn_On_Inherently_Limited_Type -- + ------------------------------------- + + procedure Warn_On_Inherently_Limited_Type (E : Entity_Id) is + C : Entity_Id; + begin + if Warnsw.Warn_On_Inherently_Limited_Type + and then not Is_Limited_Record (E) + then + C := First_Component (Base_Type (E)); + while Present (C) loop + if Is_Inherently_Limited_Type (Etype (C)) then + Error_Msg_Node_2 := E; + Error_Msg_NE + ("?_l?limited component & makes & limited", E, C); + Error_Msg_N + ("\\?_l?consider annotating the record type " + & "with a LIMITED keyword", E); + exit; + end if; + + Next_Component (C); + end loop; + end if; + end Warn_On_Inherently_Limited_Type; + end Sem_Ch3; 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_ch6.adb b/gcc/ada/sem_ch6.adb index 5735efb..8cf191d 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4135,7 +4135,9 @@ package body Sem_Ch6 is Set_Is_Public (Body_Id, False); end if; - Freeze_Before (N, Body_Id); + if not Has_Delayed_Freeze (Body_Id) then + Freeze_Before (N, Body_Id); + end if; end if; if Nkind (N) /= N_Subprogram_Body_Stub then @@ -6432,6 +6434,58 @@ package body Sem_Ch6 is OldD : constant Boolean := Present (Expression (Parent (Old_Discr))); + function Has_Tagged_Limited_Partial_View + (Typ : Entity_Id) return Boolean; + -- Returns True iff Typ has a tagged limited partial view. + + function Is_Derived_From_Immutably_Limited_Type + (Typ : Entity_Id) return Boolean; + -- Returns True iff Typ is a derived type (tagged or not) + -- whose ancestor type is immutably limited. The unusual + -- ("unusual" is one word for it) thing about this function + -- is that it handles the case where the ancestor name's Entity + -- attribute has not been set yet. + + ------------------------------------- + -- Has_Tagged_Limited_Partial_View -- + ------------------------------------- + + function Has_Tagged_Limited_Partial_View + (Typ : Entity_Id) return Boolean + is + Priv : constant Entity_Id := Incomplete_Or_Partial_View (Typ); + begin + return Present (Priv) + and then not Is_Incomplete_Type (Priv) + and then Is_Tagged_Type (Priv) + and then Limited_Present (Parent (Priv)); + end Has_Tagged_Limited_Partial_View; + + -------------------------------------------- + -- Is_Derived_From_Immutably_Limited_Type -- + -------------------------------------------- + + function Is_Derived_From_Immutably_Limited_Type + (Typ : Entity_Id) return Boolean + is + Type_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Parent_Name : Node_Id; + begin + if Nkind (Type_Def) /= N_Derived_Type_Definition then + return False; + end if; + Parent_Name := Subtype_Indication (Type_Def); + if Nkind (Parent_Name) = N_Subtype_Indication then + Parent_Name := Subtype_Mark (Parent_Name); + end if; + if Parent_Name not in N_Has_Entity_Id + or else No (Entity (Parent_Name)) + then + Find_Type (Parent_Name); + end if; + return Is_Immutably_Limited_Type (Entity (Parent_Name)); + end Is_Derived_From_Immutably_Limited_Type; + begin if NewD or OldD then @@ -6463,6 +6517,19 @@ package body Sem_Ch6 is N_Access_Definition and then not Is_Immutably_Limited_Type (Defining_Identifier (N)) + + -- Check for a case that would be awkward to handle in + -- Is_Immutably_Limited_Type (because sem_aux can't + -- "with" sem_util). + + and then not Has_Tagged_Limited_Partial_View + (Defining_Identifier (N)) + + -- Check for another case that would be awkward to handle + -- in Is_Immutably_Limited_Type + + and then not Is_Derived_From_Immutably_Limited_Type + (Defining_Identifier (N)) then Error_Msg_N ("(Ada 2005) default value for access discriminant " @@ -7361,6 +7428,8 @@ package body Sem_Ch6 is Error_Msg_N ("implied return after this statement would have raised " & "Program_Error", Last_Stm); + Error_Msg_NE + ("\procedure & is marked as No_Return!", Last_Stm, Proc); -- In normal compilation mode, do not warn on a generated call -- (e.g. in the body of a renaming as completion). @@ -7369,11 +7438,15 @@ package body Sem_Ch6 is Error_Msg_N ("implied return after this statement will raise " & "Program_Error??", Last_Stm); + + Error_Msg_NE + ("\procedure & is marked as No_Return??!", Last_Stm, Proc); + else + + Error_Msg_NE + ("procedure & is marked as No_Return!", Last_Stm, Proc); end if; - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_NE - ("\procedure & is marked as No_Return<<!", Last_Stm, Proc); end if; declare @@ -11348,11 +11421,6 @@ package body Sem_Ch6 is -- replace the overridden primitive in Typ's primitives list with -- the new subprogram. - function Visible_Part_Type (T : Entity_Id) return Boolean; - -- Returns true if T is declared in the visible part of the current - -- package scope; otherwise returns false. Assumes that T is declared - -- in a package. - procedure Check_Private_Overriding (T : Entity_Id); -- Checks that if a primitive abstract subprogram of a visible -- abstract type is declared in a private part, then it must override @@ -11361,6 +11429,17 @@ package body Sem_Ch6 is -- in a private part, then it must override a function declared in -- the visible part. + function Is_A_Primitive + (Typ : Entity_Id; + Subp : Entity_Id) return Boolean; + -- Typ is either the return type of function Subp or the type of one + -- of its formals; determine if Subp is a primitive of type Typ. + + function Visible_Part_Type (T : Entity_Id) return Boolean; + -- Returns true if T is declared in the visible part of the current + -- package scope; otherwise returns false. Assumes that T is declared + -- in a package. + --------------------------------------- -- Add_Or_Replace_Untagged_Primitive -- --------------------------------------- @@ -11529,7 +11608,17 @@ package body Sem_Ch6 is -- operation. That's illegal in the tagged case -- (but not if the private type is untagged). - if T = Base_Type (Etype (S)) then + -- Do not report this error when the tagged type has + -- the First_Controlling_Parameter aspect, unless the + -- function has a controlling result (which is only + -- possible if the function overrides an inherited + -- primitive). + + if T = Base_Type (Etype (S)) + and then + (not Has_First_Controlling_Parameter_Aspect (T) + or else Has_Controlling_Result (S)) + then Error_Msg_N ("private function with controlling result must" & " override visible-part function", S); @@ -11542,6 +11631,9 @@ package body Sem_Ch6 is elsif Ekind (Etype (S)) = E_Anonymous_Access_Type and then T = Base_Type (Designated_Type (Etype (S))) + and then + (not Has_First_Controlling_Parameter_Aspect (T) + or else Has_Controlling_Result (S)) and then Ada_Version >= Ada_2012 then Error_Msg_N @@ -11558,6 +11650,58 @@ package body Sem_Ch6 is end if; end Check_Private_Overriding; + -------------------- + -- Is_A_Primitive -- + -------------------- + + function Is_A_Primitive + (Typ : Entity_Id; + Subp : Entity_Id) return Boolean is + begin + if Scope (Typ) /= Current_Scope + or else Is_Class_Wide_Type (Typ) + or else Is_Generic_Type (Typ) + then + return False; + + -- Untagged type primitive + + elsif not Is_Tagged_Type (Typ) then + return True; + + -- Primitive of a tagged type without the First_Controlling_Param + -- aspect. + + elsif not Has_First_Controlling_Parameter_Aspect (Typ) then + return True; + + -- Non-overriding primitive of a tagged type with the + -- First_Controlling_Parameter aspect + + elsif No (Overridden_Operation (Subp)) then + return Present (First_Formal (Subp)) + and then Etype (First_Formal (Subp)) = Typ; + + -- Primitive of a tagged type with the First_Controlling_Parameter + -- aspect, overriding an inherited primitive of a tagged type + -- without this aspect. + + else + if Ekind (Subp) = E_Function + and then Has_Controlling_Result (Overridden_Operation (Subp)) + then + return True; + + elsif Is_Dispatching_Operation + (Overridden_Operation (Subp)) + then + return True; + end if; + end if; + + return False; + end Is_A_Primitive; + ----------------------- -- Visible_Part_Type -- ----------------------- @@ -11630,10 +11774,7 @@ package body Sem_Ch6 is B_Typ := Base_Type (F_Typ); - if Scope (B_Typ) = Current_Scope - and then not Is_Class_Wide_Type (B_Typ) - and then not Is_Generic_Type (B_Typ) - then + if Is_A_Primitive (B_Typ, S) then Is_Primitive := True; Set_Has_Primitive_Operations (B_Typ); Set_Is_Primitive (S); @@ -11673,10 +11814,7 @@ package body Sem_Ch6 is B_Typ := Base_Type (B_Typ); end if; - if Scope (B_Typ) = Current_Scope - and then not Is_Class_Wide_Type (B_Typ) - and then not Is_Generic_Type (B_Typ) - then + if Is_A_Primitive (B_Typ, S) then Is_Primitive := True; Set_Is_Primitive (S); Set_Has_Primitive_Operations (B_Typ); @@ -12478,8 +12616,8 @@ package body Sem_Ch6 is if Chars (E) = Name_Op_Eq then declare - Typ : constant Entity_Id - := Etype (First_Entity (E)); + Typ : constant Entity_Id := + Etype (First_Entity (E)); H : Entity_Id := Homonym (E); begin diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 9906006..13c44c5 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -8980,6 +8980,7 @@ package body Sem_Ch8 is while Present (Item) loop if Nkind (Item) = N_With_Clause and then Private_Present (Item) + and then Is_Entity_Name (Name (Item)) and then Entity (Name (Item)) = E then return True; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 391cbeb..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; @@ -3648,6 +3657,14 @@ package body Sem_Ch9 is Freeze_Before (N, Etype (Iface)); + -- Implicit inheritance of attribute + + if not Has_First_Controlling_Parameter_Aspect (T) + and then Has_First_Controlling_Parameter_Aspect (Iface_Typ) + then + Set_Has_First_Controlling_Parameter_Aspect (T); + end if; + if Nkind (N) = N_Protected_Type_Declaration then -- Ada 2005 (AI-345): Protected types can only implement diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 3c1c49f7..203e914 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -305,7 +305,36 @@ package body Sem_Disp is Formal := First_Formal (Subp); while Present (Formal) loop - Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); + Ctrl_Type := Empty; + + -- Common Ada case + + if not Has_First_Controlling_Parameter_Aspect (Typ) then + Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); + + -- Type with the First_Controlling_Parameter aspect: for overriding + -- primitives of a parent type that lacks this aspect, we cannot be + -- more restrictive than the overridden primitive. This also applies + -- to renamings of dispatching primitives. Dispatching operators can + -- have one or two controlling parameters, as long as one of them is + -- the first one, and none of the parameters have the same type as + -- the operator's result type. + + -- Internal subprograms added by the frontend bypass the restrictions + -- of First_Controlling_Parameter aspect. + + elsif Formal = First_Formal (Subp) + or else Is_Internal (Subp) + or else Present (Overridden_Operation (Subp)) + or else + (Present (Alias (Subp)) + and then Is_Dispatching_Operation (Ultimate_Alias (Subp))) + or else + (Ekind (Subp) = E_Function + and then Is_Operator_Name (Chars (Subp))) + then + Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); + end if; if Present (Ctrl_Type) then @@ -390,7 +419,24 @@ package body Sem_Disp is Next_Formal (Formal); end loop; - if Ekind (Subp) in E_Function | E_Generic_Function then + -- Functions overriding parent type primitives that lack the aspect + -- First_Controlling_Param cannot be more restrictive than the + -- overridden function. This also applies to renamings of dispatching + -- primitives. Internal subprograms added by the frontend bypass these + -- restrictions. + + if Ekind (Subp) in E_Function | E_Generic_Function + and then (not Has_First_Controlling_Parameter_Aspect (Typ) + or else Is_Internal (Subp) + or else + (Present (Overridden_Operation (Subp)) + and then + Has_Controlling_Result (Overridden_Operation (Subp))) + or else + (Present (Alias (Subp)) + and then + Has_Controlling_Result (Ultimate_Alias (Subp)))) + then Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); if Present (Ctrl_Type) then @@ -1345,8 +1391,10 @@ package body Sem_Disp is Typ := Etype (Subp); end if; - -- The following should be better commented, especially since - -- we just added several new conditions here ??? + -- Report warning on non dispatching primitives of interface + -- type Typ; this warning is disabled when the type has the + -- aspect First_Controlling_Parameter because we will report + -- an error when the interface type is frozen. if Comes_From_Source (Subp) and then Is_Interface (Typ) @@ -1354,6 +1402,7 @@ package body Sem_Disp is and then not Is_Derived_Type (Typ) and then not Is_Generic_Type (Typ) and then not In_Instance + and then not Has_First_Controlling_Parameter_Aspect (Typ) then Error_Msg_N ("??declaration of& is too late!", Subp); Error_Msg_NE @@ -1772,6 +1821,37 @@ package body Sem_Disp is -- cascaded errors. elsif not Error_Posted (Subp) then + + -- When aspect First_Controlling_Parameter applies, check if the + -- subprogram is a primitive. Internal subprograms added by the + -- frontend bypass its restrictions. + + if Has_First_Controlling_Parameter_Aspect (Tagged_Type) + and then not Is_Internal (Subp) + and then not + (Present (Overridden_Operation (Subp)) + and then + Is_Dispatching_Operation (Overridden_Operation (Subp))) + and then not + (Present (Alias (Subp)) + and then + Is_Dispatching_Operation (Ultimate_Alias (Subp))) + and then (No (First_Formal (Subp)) + or else not + Is_Controlling_Formal (First_Formal (Subp))) + then + if Warn_On_Non_Dispatching_Primitives then + Error_Msg_NE + ("?_j?not a dispatching primitive of tagged type&", + Subp, Tagged_Type); + Error_Msg_NE + ("\?_j?disallowed by 'First_'Controlling_'Parameter on &", + Subp, Tagged_Type); + end if; + + return; + end if; + Add_Dispatching_Operation (Tagged_Type, Subp); end if; @@ -2287,6 +2367,55 @@ package body Sem_Disp is --------------------------- function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is + + function Has_Predefined_Dispatching_Operation_Name return Boolean; + -- Determines if Subp has the name of a predefined dispatching + -- operation. + + ----------------------------------------------- + -- Has_Predefined_Dispatching_Operation_Name -- + ----------------------------------------------- + + function Has_Predefined_Dispatching_Operation_Name return Boolean is + TSS_Name : TSS_Name_Type; + + begin + Get_Name_String (Chars (Subp)); + + if Name_Len > TSS_Name_Type'Last then + TSS_Name := + TSS_Name_Type + (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); + + if Chars (Subp) in Name_uAssign + | Name_uSize + | Name_Op_Eq + or else TSS_Name = TSS_Deep_Adjust + or else TSS_Name = TSS_Deep_Finalize + or else TSS_Name = TSS_Stream_Input + or else TSS_Name = TSS_Stream_Output + or else TSS_Name = TSS_Stream_Read + or else TSS_Name = TSS_Stream_Write + or else TSS_Name = TSS_Put_Image + + -- Name of predefined interface type primitives + + or else Chars (Subp) in Name_uDisp_Asynchronous_Select + | Name_uDisp_Conditional_Select + | Name_uDisp_Get_Prim_Op_Kind + | Name_uDisp_Get_Task_Id + | Name_uDisp_Requeue + | Name_uDisp_Timed_Select + then + return True; + end if; + end if; + + return False; + end Has_Predefined_Dispatching_Operation_Name; + + -- Local variables + A_Formal : Entity_Id; Formal : Entity_Id; Ctrl_Type : Entity_Id; @@ -2343,7 +2472,25 @@ package body Sem_Disp is -- The subprogram may also be dispatching on result if Present (Etype (Subp)) then - return Check_Controlling_Type (Etype (Subp), Subp); + if Is_Tagged_Type (Etype (Subp)) + and then Has_First_Controlling_Parameter_Aspect (Etype (Subp)) + then + if Present (Overridden_Operation (Subp)) + and then Has_Controlling_Result (Overridden_Operation (Subp)) + then + return Check_Controlling_Type (Etype (Subp), Subp); + + -- Internal subprograms added by the frontend bypass the + -- restrictions of First_Controlling_Parameter aspect. + + elsif Is_Internal (Subp) + and then Has_Predefined_Dispatching_Operation_Name + then + return Check_Controlling_Type (Etype (Subp), Subp); + end if; + else + return Check_Controlling_Type (Etype (Subp), Subp); + end if; end if; end if; @@ -2444,6 +2591,8 @@ package body Sem_Disp is (Tagged_Type : Entity_Id; Iface_Prim : Entity_Id) return Entity_Id is + Is_FCP_Type : constant Boolean := + Has_First_Controlling_Parameter_Aspect (Tagged_Type); E : Entity_Id; El : Elmt_Id; @@ -2462,9 +2611,30 @@ package body Sem_Disp is while Present (E) loop if Is_Subprogram (E) and then Is_Dispatching_Operation (E) - and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then - return E; + -- For overriding primitives of parent or interface types that + -- do not have the aspect First_Controlling_Parameter, we must + -- temporarily unset this attribute to check conformance. + + if Ekind (E) = E_Function + and then Is_FCP_Type + and then Present (Overridden_Operation (E)) + and then Has_Controlling_Result (Overridden_Operation (E)) + then + Set_Has_First_Controlling_Parameter_Aspect (Tagged_Type, False); + + if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then + Set_Has_First_Controlling_Parameter_Aspect + (Tagged_Type, Is_FCP_Type); + return E; + end if; + + Set_Has_First_Controlling_Parameter_Aspect + (Tagged_Type, Is_FCP_Type); + + elsif Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then + return E; + end if; end if; E := Homonym (E); @@ -2501,7 +2671,28 @@ package body Sem_Disp is -- Check if E covers the interface primitive (includes case in -- which E is an inherited private primitive). - if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then + -- For overriding primitives of parent or interface types that + -- do not have the aspect First_Controlling_Parameter, we must + -- temporarily unset this attribute to check conformance. + + if Present (Overridden_Operation (E)) + and then Is_FCP_Type + and then not + Has_First_Controlling_Parameter_Aspect + (Find_Dispatching_Type (Overridden_Operation (E))) + then + Set_Has_First_Controlling_Parameter_Aspect (Tagged_Type, False); + + if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then + Set_Has_First_Controlling_Parameter_Aspect + (Tagged_Type, Is_FCP_Type); + return E; + end if; + + Set_Has_First_Controlling_Parameter_Aspect + (Tagged_Type, Is_FCP_Type); + + elsif Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then return E; end if; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 03006b6..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; @@ -6185,10 +6216,12 @@ package body Sem_Eval is if Is_Discrete_Type (T1) and then Is_Discrete_Type (T2) then declare - Interval_List1 : constant Interval_Lists.Discrete_Interval_List - := Interval_Lists.Type_Intervals (T1); - Interval_List2 : constant Interval_Lists.Discrete_Interval_List - := Interval_Lists.Type_Intervals (T2); + Interval_List1 : + constant Interval_Lists.Discrete_Interval_List := + Interval_Lists.Type_Intervals (T1); + Interval_List2 : + constant Interval_Lists.Discrete_Interval_List := + Interval_Lists.Type_Intervals (T2); begin return Interval_Lists.Is_Subset (Interval_List1, Interval_List2) and then not (Has_Predicates (T1) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 3a0572c..90f9c72 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -8148,6 +8148,11 @@ package body Sem_Prag is Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); Analyze_And_Resolve (Arg1x, Standard_Boolean); + if CodePeer_Mode then + Rewrite (N, Make_Null_Statement (Loc)); + return; + end if; + -- In GNATprove mode, pragma Compile_Time_Error is translated as -- a Check pragma in GNATprove mode, handled as an assumption in -- GNATprove. This is correct as the compiler will issue an error @@ -13489,16 +13494,16 @@ package body Sem_Prag is when N_Op_Concat => declare - L_Type : constant Entity_Id - := Preferred_String_Type (Left_Opnd (Expr)); - R_Type : constant Entity_Id - := Preferred_String_Type (Right_Opnd (Expr)); - - Type_Table : constant array (1 .. 4) of Entity_Id - := (Empty, - Standard_Wide_Wide_String, - Standard_Wide_String, - Standard_String); + L_Type : constant Entity_Id := + Preferred_String_Type (Left_Opnd (Expr)); + R_Type : constant Entity_Id := + Preferred_String_Type (Right_Opnd (Expr)); + + Type_Table : constant array (1 .. 4) of Entity_Id := + (Empty, + Standard_Wide_Wide_String, + Standard_Wide_String, + Standard_String); begin for Idx in Type_Table'Range loop if L_Type = Type_Table (Idx) or @@ -17756,6 +17761,124 @@ package body Sem_Prag is end if; end Finalize_Storage; + ---------------------------------------- + -- Pragma_First_Controlling_Parameter -- + ---------------------------------------- + + when Pragma_First_Controlling_Parameter => First_Ctrl_Param : declare + Arg : Node_Id; + E : Entity_Id := Empty; + Expr : Node_Id := Empty; + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + + Arg := Get_Pragma_Arg (Arg1); + Check_Arg_Is_Identifier (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) + or else not Is_Type (E) + or else not (Is_Tagged_Type (E) + or else Is_Concurrent_Type (E)) + then + Error_Pragma + ("pragma% must specify tagged type or concurrent type"); + end if; + + -- Check use of the pragma on private types + + if Has_Private_Declaration (E) then + declare + Prev_Id : constant Entity_Id := + Incomplete_Or_Partial_View (E); + begin + if Is_Tagged_Type (Prev_Id) then + if Has_First_Controlling_Parameter_Aspect (Prev_Id) then + Error_Pragma + ("pragma already specified in private declaration"); + else + Error_Msg_N + ("hidden 'First_'Controlling_'Parameter tagged type" + & " not allowed", N); + end if; + + -- No action needed if the partial view is not tagged. For + -- example: + + -- package Example is + -- type Private_Type is private; + -- private + -- type Private_Type is new ... with null record + -- with First_Controlling_Parameter; -- Legal + -- end; + + else + null; + end if; + end; + end if; + + -- The corresponding record type of concurrent types will not be + -- a tagged type when it does not implement some interface type. + + if Is_Concurrent_Type (E) + and then Present (Parent (E)) + and then No (Interface_List (Parent (E))) + then + if Warn_On_Non_Dispatching_Primitives then + Error_Msg_N + ("?_j?'First_'Controlling_'Parameter has no effect", N); + Error_Msg_NE + ("?_j?because & does not implement interface types", + N, E); + end if; + + else + Set_Has_First_Controlling_Parameter_Aspect (E); + end if; + end First_Ctrl_Param; + ----------- -- Ghost -- ----------- @@ -24153,6 +24276,27 @@ package body Sem_Prag is end if; end Side_Effects; + ------------------------------------ + -- Pragma_Simulate_Internal_Error -- + ------------------------------------ + + -- pragma Simulate_Internal_Error; + + -- Since the only purpose of this pragma is to write tests for the + -- compiler, it is not documented in the GNAT reference manual. The + -- effect of the pragma is to cause the compiler to raise an + -- exception when it analyzes the pragma. + + when Pragma_Simulate_Internal_Error => + Simulate_Internal_Error : declare + Simulated_Internal_Error : exception; + begin + GNAT_Pragma; + Check_Arg_Count (0); + + raise Simulated_Internal_Error; + end Simulate_Internal_Error; + ------------------------------ -- Simple_Storage_Pool_Type -- ------------------------------ @@ -32790,6 +32934,7 @@ package body Sem_Prag is Pragma_Fast_Math => 0, Pragma_Favor_Top_Level => 0, Pragma_Finalize_Storage_Only => 0, + Pragma_First_Controlling_Parameter => 0, Pragma_Ghost => 0, Pragma_Global => -1, Pragma_GNAT_Annotate => 93, @@ -32906,6 +33051,7 @@ package body Sem_Prag is Pragma_Shared_Passive => 0, Pragma_Short_Circuit_And_Or => 0, Pragma_Short_Descriptors => 0, + Pragma_Simulate_Internal_Error => 0, Pragma_Simple_Storage_Pool_Type => 0, Pragma_Source_File_Name => 0, Pragma_Source_File_Name_Project => 0, @@ -33633,7 +33779,7 @@ package body Sem_Prag is Error_Msg_N ("Check_Policy is a non-standard pragma??", N); Error_Msg_N ("\use Assertion_Policy and aspect names Pre/Post for " - & "Ada2012 conformance?", N); + & "Ada2012 conformance??", N); end if; return; diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index 557e045..48a1603 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -64,6 +64,7 @@ package Sem_Prag is Pragma_Export => True, Pragma_Extensions_Visible => True, Pragma_Favor_Top_Level => True, + Pragma_First_Controlling_Parameter => True, Pragma_Ghost => True, Pragma_Global => True, Pragma_GNAT_Annotate => True, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b23ca48..6b673a9 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -84,6 +84,7 @@ with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Sinfo.CN; use Sinfo.CN; +with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -144,10 +145,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, @@ -213,6 +214,7 @@ package body Sem_Res is procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id); + procedure Resolve_External_Initializer (N : Node_Id; Typ : Entity_Id); procedure Resolve_If_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id); procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); @@ -298,8 +300,10 @@ package body Sem_Res is procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id); -- The String_Literal_Subtype is built for all strings that are not - -- operands of a static concatenation operation. If the argument is not - -- a N_String_Literal node, then the call has no effect. + -- operands of a static concatenation operation. It is also built for + -- expressions generated by the expansion of the External_Initialization + -- aspect. If the argument is not an N_String_Literal node or an + -- N_External_Initializer node, then the call has no effect. procedure Set_Slice_Subtype (N : Node_Id); -- Build subtype of array type, with the range specified by the slice @@ -1486,28 +1490,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 -- @@ -3400,6 +3418,9 @@ package body Sem_Res is when N_Extension_Aggregate => Resolve_Extension_Aggregate (N, Ctx_Type); + when N_External_Initializer => + Resolve_External_Initializer (N, Ctx_Type); + when N_Function_Call => Resolve_Call (N, Ctx_Type); @@ -4637,6 +4658,15 @@ package body Sem_Res is A_Typ := Etype (A); F_Typ := Etype (F); + -- If A_Typ is complete and F_Typ is not, then adjust F_Typ + + if Ekind (F_Typ) = E_Incomplete_Type + and then Present (Full_View (F_Typ)) + and then not Is_Incomplete_Type (A_Typ) + then + F_Typ := Full_View (F_Typ); + end if; + -- An actual cannot be an untagged formal incomplete type if Ekind (A_Typ) = E_Incomplete_Type @@ -9361,6 +9391,15 @@ package body Sem_Res is end Resolve_Expression_With_Actions; ---------------------------------- + -- Resolve_External_Initializer -- + ---------------------------------- + + procedure Resolve_External_Initializer (N : Node_Id; Typ : Entity_Id) is + begin + Set_String_Literal_Subtype (N, Typ); + end Resolve_External_Initializer; + + ---------------------------------- -- Resolve_Generalized_Indexing -- ---------------------------------- @@ -9658,7 +9697,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 +11473,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 @@ -13023,16 +13062,23 @@ package body Sem_Res is Loc : constant Source_Ptr := Sloc (N); Low_Bound : constant Node_Id := Type_Low_Bound (Etype (First_Index (Typ))); + Length : constant Nat := + (case Nkind (N) is + when N_String_Literal => String_Length (Strval (N)), + -- Sinput.Source_Last points to an EOF character that's not in the + -- original file and we do not include that character. + when N_External_Initializer => Nat ( + Source_Last (File_Index (N)) - Source_First (File_Index (N))), + when others => 0); Subtype_Id : Entity_Id; begin - if Nkind (N) /= N_String_Literal then + if Nkind (N) not in N_String_Literal | N_External_Initializer then return; end if; Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); - Set_String_Literal_Length (Subtype_Id, UI_From_Int - (String_Length (Strval (N)))); + Set_String_Literal_Length (Subtype_Id, UI_From_Int (Length)); Set_Etype (Subtype_Id, Base_Type (Typ)); Set_Is_Constrained (Subtype_Id); Set_Etype (N, Subtype_Id); @@ -13054,7 +13100,6 @@ package body Sem_Res is else declare - Length : constant Nat := String_Length (Strval (N)); Index_List : constant List_Id := New_List; Index_Type : constant Entity_Id := Etype (First_Index (Typ)); Array_Subtype : Entity_Id; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index b76c6ef..75e7daf 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -1228,6 +1228,18 @@ package body Sem_Type is return Has_Non_Limited_View (T2) and then Covers (T1, Get_Full_View (Non_Limited_View (T2))); + -- Coverage for incomplete types + + elsif Ekind (T1) = E_Incomplete_Type + and then Present (Full_View (T1)) + then + return Covers (Full_View (T1), T2); + + elsif Ekind (T2) = E_Incomplete_Type + and then Present (Full_View (T2)) + then + return Covers (T1, Full_View (T2)); + -- Ada 2005 (AI-412): Coverage for regular incomplete subtypes elsif Ekind (T1) = E_Incomplete_Subtype then @@ -3586,6 +3598,9 @@ package body Sem_Type is if Is_Anonymous_Access_Type (T) then return Ada_Version >= Ada_2005; + elsif Is_Incomplete_Type (T) then + return False; + elsif not Is_Limited_Type (T) then return True; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3f95609..ac64b1c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5938,7 +5938,7 @@ package body Sem_Util is else Error_Msg ("\Constraint_Error will be raised" - & " for objects of this type??", Eloc, N); + & " for objects of this type", Eloc, N); end if; end if; end; @@ -9805,8 +9805,8 @@ package body Sem_Util is end if; end; else - UI_Discrim_Value - := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype)); + UI_Discrim_Value := + Expr_Value (Type_Low_Bound (Discrim_Value_Subtype)); end if; end case; @@ -9860,14 +9860,14 @@ package body Sem_Util is if Present (Variant) then if Discrim_Value_Status = Static_Subtype then declare - Discrim_Value_Subtype_Intervals - : constant Interval_Lists.Discrete_Interval_List - := Interval_Lists.Type_Intervals (Discrim_Value_Subtype); - - Variant_Intervals - : constant Interval_Lists.Discrete_Interval_List - := Interval_Lists.Choice_List_Intervals - (Discrete_Choices => Discrete_Choices (Variant)); + Discrim_Value_Subtype_Intervals : + constant Interval_Lists.Discrete_Interval_List := + Interval_Lists.Type_Intervals (Discrim_Value_Subtype); + + Variant_Intervals : + constant Interval_Lists.Discrete_Interval_List := + Interval_Lists.Choice_List_Intervals + (Discrete_Choices => Discrete_Choices (Variant)); begin if not Interval_Lists.Is_Subset (Subset => Discrim_Value_Subtype_Intervals, @@ -11616,8 +11616,8 @@ package body Sem_Util is declare Constit_Elmt : Elmt_Id; Constit_Id : Entity_Id; - Constits : constant Elist_Id - := Part_Of_Constituents (Item_Id); + Constits : constant Elist_Id := + Part_Of_Constituents (Item_Id); begin if Present (Constits) then Constit_Elmt := First_Elmt (Constits); @@ -15223,6 +15223,10 @@ package body Sem_Util is then return Is_Aliased_View (Expression (Obj)); + elsif Is_Expanded_Class_Wide_Interface_Object_Decl (Parent (Obj)) then + return Is_Aliased + (Defining_Identifier (Original_Node (Parent (Obj)))); + -- The dereference of an access-to-object value denotes an aliased view, -- but this routine uses the rules of the language so we need to exclude -- rewritten constructs that introduce artificial dereferences. @@ -15914,10 +15918,8 @@ package body Sem_Util is elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then return False; - elsif Nkind (Parent (Par)) in - N_Function_Call | - N_Procedure_Call_Statement | - N_Entry_Call_Statement + elsif Nkind (Parent (Par)) in N_Entry_Call_Statement + | N_Subprogram_Call then -- Check that the element is not part of an actual for an -- in-out parameter. @@ -15928,14 +15930,14 @@ package body Sem_Util is begin F := First_Formal (Entity (Name (Parent (Par)))); - A := First (Parameter_Associations (Parent (Par))); + A := First_Actual (Parent (Par)); while Present (F) loop if A = Par and then Ekind (F) /= E_In_Parameter then return False; end if; Next_Formal (F); - Next (A); + Next_Actual (A); end loop; end; @@ -18618,8 +18620,8 @@ package body Sem_Util is function Is_Null_Extension_Of (Descendant, Ancestor : Entity_Id) return Boolean is - Ancestor_Type : constant Entity_Id - := Underlying_Type (Base_Type (Ancestor)); + Ancestor_Type : constant Entity_Id := + Underlying_Type (Base_Type (Ancestor)); Descendant_Type : Entity_Id := Underlying_Type (Base_Type (Descendant)); begin pragma Assert (not Is_Class_Wide_Type (Descendant)); @@ -29897,8 +29899,8 @@ package body Sem_Util is Comp := First (Component_Associations (N)); while Present (Comp) loop declare - Choice_Intervals : constant Discrete_Interval_List - := Choice_List_Intervals (Choices (Comp)); + Choice_Intervals : constant Discrete_Interval_List := + Choice_List_Intervals (Choices (Comp)); begin for J in Choice_Intervals'Range loop Num_I := Num_I + 1; @@ -29912,8 +29914,8 @@ package body Sem_Util is -- Normalize the lists sorting and merging the intervals declare - Aggr_Intervals : Discrete_Interval_List (1 .. Num_I) - := Intervals (1 .. Num_I); + Aggr_Intervals : Discrete_Interval_List (1 .. Num_I) := + Intervals (1 .. Num_I); begin Normalize_Interval_List (Aggr_Intervals, Num_I); Check_Consistency (Aggr_Intervals (1 .. Num_I)); @@ -29991,8 +29993,8 @@ package body Sem_Util is while Present (Choice) loop if Nkind (Choice) = N_Others_Choice then declare - Others_Choice : Node_Id - := First (Others_Discrete_Choices (Choice)); + Others_Choice : Node_Id := + First (Others_Discrete_Choices (Choice)); begin while Present (Others_Choice) loop Count := Count + 1; @@ -30027,8 +30029,8 @@ package body Sem_Util is when N_Subtype_Indication => declare - Range_Exp : constant Node_Id - := Range_Expression (Constraint (Choice)); + Range_Exp : constant Node_Id := + Range_Expression (Constraint (Choice)); begin return (Low => Expr_Value (Low_Bound (Range_Exp)), High => Expr_Value (High_Bound (Range_Exp))); @@ -30175,8 +30177,8 @@ package body Sem_Util is Not_Null : Pos range List'Range; -- Index of the most recently examined non-null interval - Null_Interval : constant Discrete_Interval - := (Low => Uint_1, High => Uint_0); -- any null range ok here + Null_Interval : constant Discrete_Interval := + (Low => Uint_1, High => Uint_0); -- any null range ok here begin if List'Length = 0 or else Is_Null (List'First) then Null_Interval_Count := List'Length; @@ -30970,9 +30972,9 @@ package body Sem_Util is ------------------------------------------- procedure Declare_Indirect_Temp_Via_Allocation is - Access_Type_Id : constant Entity_Id - := Make_Temporary - (Loc, Indirect_Temp_Access_Type_Char, Attr_Prefix); + Access_Type_Id : constant Entity_Id := + Make_Temporary + (Loc, Indirect_Temp_Access_Type_Char, Attr_Prefix); Temp_Decl : constant Node_Id := Make_Object_Declaration (Loc, @@ -31018,14 +31020,14 @@ package body Sem_Util is return New_Occurrence_Of (Typ, Loc); end Designated_Subtype_Mark; - Access_Type_Def : constant Node_Id - := Make_Access_To_Object_Definition - (Loc, Subtype_Indication => Designated_Subtype_Mark); + Access_Type_Def : constant Node_Id := + Make_Access_To_Object_Definition + (Loc, Subtype_Indication => Designated_Subtype_Mark); - Access_Type_Decl : constant Node_Id - := Make_Full_Type_Declaration - (Loc, Access_Type_Id, - Type_Definition => Access_Type_Def); + Access_Type_Decl : constant Node_Id := + Make_Full_Type_Declaration + (Loc, Access_Type_Id, + Type_Definition => Access_Type_Def); begin Mutate_Ekind (Temp_Id, E_Variable); Set_Etype (Temp_Id, Access_Type_Id); diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index ca38515..49e9d90 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -3511,15 +3511,15 @@ package body Sem_Warn is Error_Msg_Sloc := Sloc (CV); if Nkind (CV) not in N_Subexpr then - Error_Msg_N ("\\??(see test #)", N); + Error_Msg_N ("\\?c?(see test #)", N); elsif Nkind (Parent (CV)) = N_Case_Statement_Alternative then - Error_Msg_N ("\\??(see case alternative #)", N); + Error_Msg_N ("\\?c?(see case alternative #)", N); else - Error_Msg_N ("\\??(see assignment #)", N); + Error_Msg_N ("\\?c?(see assignment #)", N); end if; end if; end; diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb index 0d4714b..2113312 100644 --- a/gcc/ada/set_targ.adb +++ b/gcc/ada/set_targ.adb @@ -837,11 +837,11 @@ begin save_argc : Nat; pragma Import (C, save_argc); - -- Saved value of argc (number of arguments), imported from misc.c + -- Saved value of argc (number of arguments), imported from misc.cc save_argv : Arg_Array_Ptr; pragma Import (C, save_argv); - -- Saved value of argv (argument pointers), imported from misc.c + -- Saved value of argv (argument pointers), imported from misc.cc gnat_argc : Nat; gnat_argv : Arg_Array_Ptr; diff --git a/gcc/ada/sigtramp-armdroid.c b/gcc/ada/sigtramp-android-asm.h index c8b2a0a..72cebae 100644 --- a/gcc/ada/sigtramp-armdroid.c +++ b/gcc/ada/sigtramp-android-asm.h @@ -2,11 +2,11 @@ * * * GNAT COMPILER COMPONENTS * * * - * S I G T R A M P * + * S I G T R A M P - T A R G E T * * * - * Asm Implementation File * + * Asm Implementation Include File * * * - * Copyright (C) 2015-2024, Free Software Foundation, Inc. * + * Copyright (C) 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- * @@ -29,62 +29,19 @@ * * ****************************************************************************/ -/****************************************************** - * ARM-Android version of the __gnat_sigtramp service * - ******************************************************/ +/***************************************************************** + * CPU specific parts of the __gnat_sigtramp service for Android * + *****************************************************************/ -#include <sys/ucontext.h> +/* The intended use mode of this header is to provide macros + and a prologue to the generation of an asm function, as in -#include "sigtramp.h" -/* See sigtramp.h for a general explanation of functionality. */ + #include <this-header> + asm (SIGTRAMP_START(<symbol-name>)); + asm (SIGTRAMP_BODY); + asm (SIGTRAMP_END(<symbol-name>)); -/* ---------------------- - -- General comments -- - ---------------------- - - Stubs are generated from toplevel asms, - The general idea is to establish CFA as the sigcontext - and state where to find the registers as offsets from there. - - We support stubs for VxWorks and Android, providing unwind info for - common registers. We might need variants with support for floating - point or altivec registers as well at some point. - - For Android it would be simpler to write this in Asm since there's only - one variant, but to keep it looking like the VxWorks stubs, - C is the choice for our toplevel interface. - - Note that the registers we "restore" here are those to which we have - direct access through the system sigcontext structure, which includes - only a partial set of the non-volatiles ABI-wise. */ - -/* ----------------------------------------- - -- Protypes for our internal asm stubs -- - ----------------------------------------- - - The registers are expected to be at SIGCONTEXT + 12 (reference the - sicontext structure in asm/sigcontext.h which describes the first - 3 * 4byte fields.) Even though our symbols will remain local, the - prototype claims "extern" and not "static" to prevent compiler complaints - about a symbol used but never defined. */ - -/* sigtramp stub providing unwind info for common registers. */ - -extern void __gnat_sigtramp_common - (int signo, void *siginfo, void *sigcontext, - __sigtramphandler_t * handler); - -void __gnat_sigtramp (int signo, void *si, void *sc, - __sigtramphandler_t * handler) - __attribute__((optimize(2))); - -void __gnat_sigtramp (int signo, void *si, void *ucontext, - __sigtramphandler_t * handler) -{ - struct sigcontext *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; - - __gnat_sigtramp_common (signo, si, mcontext, handler); -} + and nothing else after. */ /* asm string construction helpers. */ @@ -103,6 +60,8 @@ void __gnat_sigtramp (int signo, void *si, void *ucontext, #undef TCR #define TCR(S) TAB(CR(S)) +#if defined(__arm__) + /* Trampoline body block --------------------- */ @@ -145,19 +104,9 @@ TCR(".fnstart") CR(".fnend") \ TCR(".size " S(SYM) ", .-" S(SYM)) -/*---------------------------- - -- And now, the real code -- - ---------------------------- */ +#endif /* Text section start. The compiler isn't aware of that switch. */ asm (".text\n" TCR(".align 2")); - -/* sigtramp stub for common registers. */ - -#define TRAMP_COMMON __gnat_sigtramp_common - -asm (SIGTRAMP_START(TRAMP_COMMON)); -asm (SIGTRAMP_BODY); -asm (SIGTRAMP_END(TRAMP_COMMON)); diff --git a/gcc/ada/sigtramp-android.c b/gcc/ada/sigtramp-android.c new file mode 100644 index 0000000..2fd42ba --- /dev/null +++ b/gcc/ada/sigtramp-android.c @@ -0,0 +1,79 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * S I G T R A M P * + * * + * C/Asm Implementation File * + * * + * Copyright (C) 2015-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. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * In particular, you can freely distribute your programs built with the * + * GNAT Pro compiler, including any required library run-time units, using * + * any licensing terms of your choosing. See the AdaCore Software License * + * for full details. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/************************************************** + * Android version of the __gnat_sigtramp service * + **************************************************/ + +#include "sigtramp.h" + +/* The ARM port relies on CFI info setup here. Others such as aarch64 + rely on kernel CFI and may relay to the handler directly. */ + +#if defined(__arm__) +#define __SETUP_CFI 1 +#else +#define __SETUP_CFI 0 +#endif + +#if __SETUP_CFI + +/* Craft a sigtramp stub providing unwind info for common registers. */ + +#define TRAMP_COMMON __gnat_sigtramp_common +extern void TRAMP_COMMON + (int signo, void *siginfo, void *sigcontext, + __sigtramphandler_t * handler); + +#include <sys/ucontext.h> + +void __gnat_sigtramp (int signo, void *si, void *ucontext, + __sigtramphandler_t * handler) +{ + struct sigcontext *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; + TRAMP_COMMON (signo, si, mcontext, handler); +} + +#include <sigtramp-android-asm.h> + +asm (SIGTRAMP_START(TRAMP_COMMON)); +asm (SIGTRAMP_BODY); +asm (SIGTRAMP_END(TRAMP_COMMON)); + +#else /* !__SETUP_CFI */ + +void __gnat_sigtramp (int signo, void *si, void *ucontext, + __sigtramphandler_t * handler) +{ + handler (signo, si, ucontext); +} + +#endif diff --git a/gcc/ada/sigtramp.h b/gcc/ada/sigtramp.h index f99bc20..3c28c8a 100644 --- a/gcc/ada/sigtramp.h +++ b/gcc/ada/sigtramp.h @@ -29,11 +29,19 @@ * * ****************************************************************************/ -/* On targets where this is implemented, we resort to a signal trampoline to - set up the DWARF Call Frame Information that lets unwinders walk through - the signal frame up into the interrupted user code. This file introduces - the relevant declarations. It should only be #included on targets that do - implement the signal trampoline. */ +/* On targets where this is useful, a signal handler trampoline is setup to + allow interposing handcrafted DWARF Call Frame Information that lets + unwinders walk through a signal frame up into the interrupted user code. + This file introduces the relevant declarations. + + For an OS family, in specific CPU configurations where kernel signal CFI + is known to be available, the trampoline may directly call the intended + handler without any intermediate CFI magic. + + sigtramp*.c offers a convenient spot for picking such alternatives, as + it allows testing for precise target predicates and is easily shared + by the tasking and non-tasking runtimes for a given OS (e.g. s-intman.adb + and init.c:__gnat_error_handler). */ #ifdef __cplusplus extern "C" { @@ -54,7 +62,8 @@ extern void __gnat_sigtramp (int signo, void *siginfo, void *sigcontext, __sigtramphandler_t * handler); /* The signal trampoline is to be called from an established signal handler. - It sets up the DWARF CFI and calls HANDLER (SIGNO, SIGINFO, SIGCONTEXT). + It calls HANDLER (SIGNO, SIGINFO, SIGCONTEXT) after setting up the DWARF + CFI if needed. The trampoline construct makes it so that the unwinder jumps over it + the signal handler + the kernel frame. For a typical backtrace from the raise diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb index 25bb09d..23485aa 100644 --- a/gcc/ada/sinfo-utils.adb +++ b/gcc/ada/sinfo-utils.adb @@ -255,6 +255,7 @@ package body Sinfo.Utils is when Flag_Field | Node_Kind_Type_Field | Entity_Kind_Type_Field + | Source_File_Index_Field | Source_Ptr_Field | Small_Paren_Count_Type_Field | Convention_Id_Field diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index beecc2c..746207a 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1291,6 +1291,10 @@ package Sinfo is -- modifications performed on the original expression such as replacement -- of the current type instance or substitutions of primitives. + -- File_Index + -- Present in N_External_Initializer nodes. Contains a Source_File_Index + -- that references the file the external initializer points to. + -- First_Inlined_Subprogram -- Present in the N_Compilation_Unit node for the main program. Points -- to a chain of entities for subprograms that are to be inlined. The @@ -8070,6 +8074,17 @@ package Sinfo is -- the expression of the node is fully analyzed and expanded, at which -- point it is safe to remove it, since no more actions can be inserted. + -------------------------- + -- External Initializer -- + -------------------------- + + -- This node is used to represent an instance of the + -- External_Initialization aspect. + + -- N_External_Initializer + -- File_Index + -- plus fields for expression + -------------------- -- Free Statement -- -------------------- diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index 8538a06..2b7439f 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -276,6 +276,23 @@ package body Sinput is return +Buf; end Build_Location_String; + --------------------- + -- C_Source_Buffer -- + --------------------- + + function C_Source_Buffer (S : SFI) return C_Array is + Length : constant Integer := + Integer (Source_Last (S) - Source_First (S)); + + Text : constant Source_Buffer_Ptr := Source_Text (S); + + Pointer : constant access constant Character := + (if Length = 0 then null else + Text (Text'First)'Access); + begin + return (Pointer, Length); + end C_Source_Buffer; + ------------------- -- Check_For_BOM -- ------------------- diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index 1045acd..d33c470 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -706,6 +706,15 @@ package Sinput is -- reloaded. It is intended for tools that parse several times sources, -- to avoid memory leaks. + type C_Array is record + Pointer : aliased access constant Character; + Length : aliased Integer; + end record; + -- WARNING: There is a matching C declaration of this type in fe.h + + function C_Source_Buffer (S : SFI) return C_Array; + -- WARNING: There is a matching C declaration of this subprogram in fe.h + private pragma Inline (File_Name); pragma Inline (Full_File_Name); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 3ed4d3a..b706896 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -155,6 +155,7 @@ package Snames is Name_Disable_Controlled : constant Name_Id := N + $; Name_Dynamic_Predicate : constant Name_Id := N + $; Name_Exclusive_Functions : constant Name_Id := N + $; + Name_External_Initialization : constant Name_Id := N + $; Name_Finalizable : constant Name_Id := N + $; Name_Full_Access_Only : constant Name_Id := N + $; Name_Ghost_Predicate : constant Name_Id := N + $; @@ -567,6 +568,7 @@ package Snames is Name_Extensions_Visible : constant Name_Id := N + $; -- GNAT Name_External : constant Name_Id := N + $; -- GNAT Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT + Name_First_Controlling_Parameter : constant Name_Id := N + $; Name_Ghost : constant Name_Id := N + $; -- GNAT Name_Global : constant Name_Id := N + $; -- GNAT Name_Ident : constant Name_Id := N + $; -- GNAT @@ -678,6 +680,9 @@ package Snames is Name_Shared_Passive : constant Name_Id := N + $; Name_Side_Effects : constant Name_Id := N + $; -- GNAT Name_Simple_Storage_Pool_Type : constant Name_Id := N + $; -- GNAT + Name_Simulate_Internal_Error : constant Name_Id := N + $; -- GNAT + Name_Source_Reference : constant Name_Id := N + $; -- GNAT + Name_Static_Elaboration_Desired : constant Name_Id := N + $; -- GNAT -- Note: Storage_Size is not in this list because its name matches the name -- of the corresponding attribute. However, it is included in the @@ -687,8 +692,6 @@ package Snames is -- Note: Storage_Unit is also omitted from the list because of a clash with -- an attribute name, and is treated similarly. - Name_Source_Reference : constant Name_Id := N + $; -- GNAT - Name_Static_Elaboration_Desired : constant Name_Id := N + $; -- GNAT Name_Stream_Convert : constant Name_Id := N + $; -- GNAT Name_Subprogram_Variant : constant Name_Id := N + $; -- GNAT Name_Subtitle : constant Name_Id := N + $; -- GNAT @@ -1870,6 +1873,7 @@ package Snames is Pragma_Extensions_Visible, Pragma_External, Pragma_Finalize_Storage_Only, + Pragma_First_Controlling_Parameter, Pragma_Ghost, Pragma_Global, Pragma_Ident, @@ -1949,6 +1953,7 @@ package Snames is Pragma_Shared_Passive, Pragma_Side_Effects, Pragma_Simple_Storage_Pool_Type, + Pragma_Simulate_Internal_Error, Pragma_Source_Reference, Pragma_Static_Elaboration_Desired, Pragma_Stream_Convert, diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index ea16591..321fd7f 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -1840,6 +1840,9 @@ package body Sprint is Write_Char (';'); + when N_External_Initializer => + null; + when N_Delta_Aggregate => Write_Str_With_Col_Check_Sloc ("("); Sprint_Node (Expression (Node)); diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index c405dec..74b629c 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -38,6 +38,7 @@ with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinput; use Sinput; with Stylesw; use Stylesw; +with Uintp; use Uintp; package body Styleg is @@ -672,8 +673,9 @@ package body Styleg is begin if Style_Check_Max_Line_Length then if Len > Style_Max_Line_Length then + Error_Msg_Uint_1 := UI_From_Int (Len); Error_Msg - ("(style) this line is too long?M?", + ("(style) this line is too long: ^?M?", Current_Line_Start + Source_Ptr (Style_Max_Line_Length)); end if; end if; 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/types.ads b/gcc/ada/types.ads index 97fbbf4..bc466f6 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -147,7 +147,7 @@ package Types is type Text_Ptr is new Int range -4 .. Int'Last; -- -4 .. -1 are special; see constants below - type Text_Buffer is array (Text_Ptr range <>) of Character; + type Text_Buffer is array (Text_Ptr range <>) of aliased Character; -- Text buffer used to hold source file or library information file type Text_Buffer_Ptr is access all Text_Buffer; diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 59cbd6f..38a82be 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -527,6 +527,9 @@ begin "primitives"); Write_Line (" .J* turn off warnings for late dispatching " & "primitives"); + Write_Line (" _j turn on warnings for First_Controlling_" & + "Parameter aspect"); + Write_Line (" k+ turn on warnings on constant variable"); Write_Line (" K* turn off warnings on constant variable"); Write_Line (" .k turn on warnings for standard redefinition"); @@ -535,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 " & diff --git a/gcc/ada/version.c b/gcc/ada/version.c index 5e64edd..2fa9b8c 100644 --- a/gcc/ada/version.c +++ b/gcc/ada/version.c @@ -31,4 +31,7 @@ #include "version.h" -char gnat_version_string[] = version_string; +/* Logically a reference to Gnatvsn.Ver_Len_Max. Please keep in sync. */ +#define VER_LEN_MAX 256 + +char gnat_version_string[VER_LEN_MAX] = version_string; diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index 4c6934d..2bfb56e 100644 --- a/gcc/ada/warnsw.adb +++ b/gcc/ada/warnsw.adb @@ -92,12 +92,14 @@ package body Warnsw is 'z' => X.Warn_On_Size_Alignment), '_' => - ('b' | 'd' | 'e' | 'f' | 'g' | 'h' | 'i' | 'j' | 'k' | 'l' | 'm' | + ('b' | 'd' | 'e' | 'f' | 'g' | 'h' | 'i' | 'k' | 'm' | 'n' | 'o' | 't' | 'u' | 'v' | 'w' | 'x' | 'y' | 'z' => No_Such_Warning, 'a' => X.Warn_On_Anonymous_Allocators, 'c' => X.Warn_On_Unknown_Compile_Time_Warning, + 'j' => X.Warn_On_Non_Dispatching_Primitives, + 'l' => X.Warn_On_Inherently_Limited_Type, 'p' => X.Warn_On_Pedantic_Checks, 'q' => X.Warn_On_Ignored_Equality, 'r' => X.Warn_On_Component_Order, @@ -190,6 +192,7 @@ package body Warnsw is -- These warnings are removed from the -gnatwa set Implementation_Unit_Warnings := False; + Warn_On_Non_Dispatching_Primitives := False; Warn_On_Non_Local_Exception := False; No_Warn_On_Non_Local_Exception := True; Warn_On_Reverse_Bit_Order := False; diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads index 5dab970..0ca0f68 100644 --- a/gcc/ada/warnsw.ads +++ b/gcc/ada/warnsw.ads @@ -72,9 +72,11 @@ package Warnsw is Warn_On_Hiding, Warn_On_Ignored_Equality, Warn_On_Ineffective_Predicate_Test, + Warn_On_Inherently_Limited_Type, Warn_On_Late_Primitives, Warn_On_Modified_Unread, Warn_On_No_Value_Assigned, + Warn_On_Non_Dispatching_Primitives, Warn_On_Non_Local_Exception, No_Warn_On_Non_Local_Exception, Warn_On_Object_Renames_Function, @@ -157,8 +159,10 @@ package Warnsw is Warn_On_Hiding | Warn_On_Ignored_Equality | Warn_On_Ineffective_Predicate_Test | + Warn_On_Inherently_Limited_Type | Warn_On_Late_Primitives | Warn_On_Modified_Unread | + Warn_On_Non_Dispatching_Primitives | Warn_On_Non_Local_Exception | No_Warn_On_Non_Local_Exception | Warn_On_Object_Renames_Function | @@ -340,6 +344,11 @@ package Warnsw is -- values that do not belong to the parent subtype. Modified by use of -- -gnatw_s/S. + Warn_On_Inherently_Limited_Type : Boolean renames F (X.Warn_On_Inherently_Limited_Type); + -- Set to True to generate warnings if a record type does not have a + -- limited keyword, but is inherently limited. Modified by use of + -- -gnatw_l/L. + Warn_On_Late_Primitives : Boolean renames F (X.Warn_On_Late_Primitives); -- Warn when tagged type public primitives are defined after its private -- extensions. @@ -357,6 +366,11 @@ package Warnsw is -- suppress such warnings. The default is that such warnings are enabled. -- Modified by use of -gnatwv/V. + Warn_On_Non_Dispatching_Primitives : Boolean renames F (X.Warn_On_Non_Dispatching_Primitives); + -- Set to True to generate warnings for non dispatching primitives of tagged + -- types that have aspect/pragma First_Controlling_Parameter set to True. + -- This is turned on by -gnatw_j and turned off by -gnatw_J + Warn_On_Non_Local_Exception : Boolean renames F (X.Warn_On_Non_Local_Exception); -- Set to True to generate warnings for non-local exception raises and also -- handlers that can never handle a local raise. This warning is only ever |