diff options
| author | Ian Lance Taylor <ian@gcc.gnu.org> | 2018-07-31 20:32:08 +0000 |
|---|---|---|
| committer | Ian Lance Taylor <ian@gcc.gnu.org> | 2018-07-31 20:32:08 +0000 |
| commit | 414925ab0cb8d0aea39cb3383b18f72f3ce887a0 (patch) | |
| tree | 2f08571e507f4d5a958e113cb0fde621c42c138e /gcc/ada | |
| parent | ce311a8cae4489058f8601bebdf511b7fb5fce26 (diff) | |
| parent | 8810325ff666643de80110c5c6b4ce1cef921e1b (diff) | |
| download | gcc-414925ab0cb8d0aea39cb3383b18f72f3ce887a0.zip gcc-414925ab0cb8d0aea39cb3383b18f72f3ce887a0.tar.gz gcc-414925ab0cb8d0aea39cb3383b18f72f3ce887a0.tar.bz2 | |
Merge from trunk revision 263114.
From-SVN: r263179
Diffstat (limited to 'gcc/ada')
130 files changed, 6421 insertions, 3364 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6b883b9..c6f1911 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,1112 @@ +2018-07-31 Arnaud Charlet <charlet@adacore.com> + + * clean.adb, gnatchop.adb, gnatfind.adb, gnatls.adb, + gnatmake.ads, gnatxref.adb, make.adb, make.ads, make_util.ads, + sfn_scan.adb, vxaddr2line.adb, xeinfo.adb, xoscons.adb, + xr_tabls.adb, xref_lib.adb: Address CodePeer messages. + +2018-07-31 Arnaud Charlet <charlet@adacore.com> + + * gnatlink.adb: Fix potential Constraint_Error if + Library_Version is too long. + +2018-07-31 Arnaud Charlet <charlet@adacore.com> + + * sem_elab.adb: Remove duplicate condition detected by CodePeer. + +2018-07-31 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.adb (Subp_Index): In the case of a protected + operation, the relevant entry is the generated + protected_subprogram_body into which the original body is + rewritten. Assorted cleanup and optimizations. + +2018-07-31 Ed Schonberg <schonberg@adacore.com> + + * exp_attr.adb (Expand_Attribute, case Fixed_Value): Set the + base type of the result to ensure that proper overflow and range + checks are generated. If the target is a fixed-point tyoe, + generate the required overflow and range checks explicitly, + rather than relying on Apply_Type_Conversion_Checks, which might + simply set the Do_Range_Check flag and rely on the backend to + add the check. + +2018-07-31 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Resolve_Call): Establish a transient scope to + manage the secondary stack when the designated type of an + access-to-subprogram requires it. + +2018-07-31 Ed Schonberg <schonberg@adacore.com> + + * exp_ch7.adb (Check_Unnesting_Elaboration_Code): To find local + subprograms in the elaboration code for a package body, recurse + through nested statement sequences because a compiler-generated + procedure may appear within a condition statement. + +2018-07-31 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Expand_Protected_Subprogram_Call): Handle + properly a protected call that includes a default parameter that + is a call to a protected function of the same type. + +2018-07-31 Justin Squirek <squirek@adacore.com> + + * lib-writ.adb (Write_With_Lines): Modfiy the generation of + dependencies within ali files so that source unit bodies are + properly listed even if said bodies are missing. Perform legacy + behavior in GNATprove mode. + * lib-writ.ads: Modify documentation to reflect current behavior. + +2018-07-31 Eric Botcazou <ebotcazou@adacore.com> + + * libgnarl/s-osinte__solaris.ads (upad64_t): New private type. + (mutex_t): Use it for 'lock' and 'data' components. + (cond_t): Likewise for 'data' and use single 'flags' component. + +2018-07-31 Justin Squirek <squirek@adacore.com> + + * exp_ch5.adb (Make_Field_Assign): Force temporarily generated + objects for assignment of overlaid user objects to be renamings + instead of constant declarations. + +2018-07-31 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch9.adb (Analyze_Pragmas): New routine. + (Build_Private_Protected_Declaration): Code clean up. Relocate + relevant aspects and pragmas from the stand-alone body to the + newly created spec. Explicitly analyze any pragmas that have + been either relocated or produced by the analysis of the + aspects. + (Move_Pragmas): New routine. + * sem_prag.adb (Find_Related_Declaration_Or_Body): Recognize the + case where a pragma applies to the internally created spec for a + stand-along subprogram body declared in a protected body. + +2018-07-31 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.adb (Expand_N_Extended_Return_Statement): Replace + calls to Current_Scope in three assertions with calls to + Current_Subprogram. + +2018-07-31 Ed Schonberg <schonberg@adacore.com> + + * sem_eval.adb (Check_Non_Static_Context): Do not warn on an + integer literal greater than the upper bound of + Universal_Integer'Last when expansion is disabled, to avoid a + spurious warning over ranges involving 64-bit modular types. + +2018-07-31 Arnaud Charlet <charlet@adacore.com> + + * einfo.adb (Write_Entity_Flags): Also print + Is_Activation_Record flag. + +2018-07-31 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb, exp_ch4.adb, exp_ch6.adb, lib-xref.adb, + repinfo.adb, sem_ch9.adb: Minor replace Ekind membership tests + with a wrapper routine. + +2018-07-31 Piotr Trojanek <trojanek@adacore.com> + + * ali.adb (Known_ALI_Lines): Remove 'F' as a prefix for lines + related to the FORMAL analysis done by GNATprove. + +2018-07-31 Javier Miranda <miranda@adacore.com> + + * sem.ads (Inside_Preanalysis_Without_Freezing): New global + counter. + * sem.adb (Semantics): This subprogram has now the + responsibility of resetting the counter before analyzing a unit, + and restoring its previous value before returning. + * freeze.adb (Freeze_Entity): Do not freeze if we are + preanalyzing without freezing. + * sem_res.adb (Preanalyze_And_Resolve): Set & restore + In_Preanalysis_Without_Freezing. + +2018-07-31 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Traverse_Homonyms): Consider generic actuals that + may rename a matching class-wide operation only if the renaming + declaration for that actual is in an enclosing scope (i.e. + within the corrresponding instance). + +2018-07-31 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb, contracts.adb, exp_aggr.adb, exp_ch5.adb, + exp_disp.adb, make.adb, sem_ch4.adb, sem_eval.adb, sem_res.adb, + usage.adb: Minor reformatting. + +2018-07-31 Bob Duff <duff@adacore.com> + + * sem_res.adb (Resolve_Allocator): Do not complain about the + implicit allocator that occurs in the expansion of a return + statement for a build-in-place function. + +2018-07-20 Martin Sebor <msebor@redhat.com> + + PR middle-end/82063 + * gcc-interface/misc.c (gnat_handle_option): Change function argument + to HOST_WIDE_INT. + +2018-07-17 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (choices_to_gnu): Rename parameters. Deal with + an operand of Character type. Factor out range generation to the end. + Check that the bounds are literals and convert them to the type of the + operand before building the ranges. + * gcc-interface/utils.c (make_dummy_type): Minor tweak. + (make_packable_type): Propagate TYPE_DEBUG_TYPE. + (maybe_pad_type): Likewise. + +2018-07-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Try_Object_Operation): Handle properly a prefixed call + in an instance, when the generic parameters include an interface type + and a abstract operation of that type, and the actuals in the instance + include an interface type and a corresponding abstract operation of it, + with a different name than the corresponding generic subprogram + parameter. + +2018-07-17 Arnaud Charlet <charlet@adacore.com> + + * sem_eval.adb (Rewrite_In_Raise_CE): Keep the original reason in more + cases. + +2018-07-17 Arnaud Charlet <charlet@adacore.com> + + * checks.adb (Apply_Division_Check): Add provision for floating-point + checks. + +2018-07-17 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Component_OK_For_Backend): If an array component of the + enclosing record has a bound that is out of range (and that has been + rewritten as a raise statement) the aggregate is not OK for any back + end, and should be expanded into individual assignments. + +2018-07-17 Piotr Trojanek <trojanek@adacore.com> + + * atree.adb (Relocate_Node): Simplify with Is_Rewrite_Substitution. + +2018-07-17 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.ads (Denotes_Same_Object): Likewise. + * sem_warn.adb (Warn_On_Overlapping_Actuals): Fix RM rule references. + +2018-07-17 Eric Botcazou <ebotcazou@adacore.com> + + * exp_disp.adb (Make_Tags): When the type has user-defined primitives, + build the access type that is later used by Build_Get_Prim_Op_Address + as pointing to a subtype of Ada.Tags.Address_Array. + +2018-07-17 Patrick Bernardi <bernardi@adacore.com> + + * libgnat/s-memory__mingw.adb: Remove. + * Makefile.rtl: Remove s-memory.adb target pair from the Cygwin/Mingw32 + section. + +2018-07-17 Hristian Kirtchev <kirtchev@adacore.com> + + * frontend.adb (Frontend): The removal of ignored Ghost code must be + the last semantic operation performed on the tree. + +2018-07-17 Hristian Kirtchev <kirtchev@adacore.com> + + * frontend.adb (Frontend): Update the call to Register_Config_Switches. + * inline.ads: Add new component Config_Switches to record + Pending_Body_Info which captures the configuration state of the pending + body. Remove components Version, Version_Pragma, SPARK_Mode, and + SPARK_Mode_Pragma from record Pending_Body_Info because they are + already captured in component Config_Switches. + * opt.adb (Register_Opt_Config_Switches): Rename to + Register_Config_Switches. + (Restore_Opt_Config_Switches): Rename to Restore_Config_Switches. + (Save_Opt_Config_Switches): Rename to Save_Config_Switches. This + routine is now a function, and returns the saved configuration state as + an aggregate to avoid missing an attribute. + (Set_Opt_Config_Switches): Rename to Set_Config_Switches. + * opt.ads (Register_Opt_Config_Switches): Rename to + Register_Config_Switches. + (Restore_Opt_Config_Switches): Rename to Restore_Config_Switches. + (Save_Opt_Config_Switches): Rename to Save_Config_Switches. This + routine is now a function. + (Set_Opt_Config_Switches): Rename to Set_Config_Switches. + * par.adb (Par): Update the calls to configuration switch-related + subprograms. + * sem.adb (Semantics): Update the calls to configuration switch-related + subprograms. + * sem_ch10.adb (Analyze_Package_Body_Stub): Update the calls to + configuration switch-related subprograms. + (Analyze_Protected_Body_Stub): Update the calls to configuration + switch-related subprograms. + (Analyze_Subprogram_Body_Stub): Update calls to configuration + switch-related subprograms. + * sem_ch12.adb (Add_Pending_Instantiation): Update the capture of + pending instantiation attributes. + (Inline_Instance_Body): Update the capture of pending instantiation + attributes. It is no longer needed to explicitly manipulate the SPARK + mode. + (Instantiate_Package_Body): Update the restoration of the context + attributes. + (Instantiate_Subprogram_Body): Update the restoration of context + attributes. + (Load_Parent_Of_Generic): Update the capture of pending instantiation + attributes. + (Set_Instance_Env): Update the way relevant configuration attributes + are saved and restored. + +2018-07-17 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Deal with + more rvalues in the expression of a renaming. + +2018-07-17 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/ada-tree.h (TYPE_RETURN_BY_DIRECT_REF_P): Define for + METHOD_TYPE too. + (TYPE_RETURN_UNCONSTRAINED_P): Likewise. + (TYPE_CI_CO_LIST): Likewise. + * gcc-interface/gigi.h (is_cplusplus_method): Delete. + (fntype_same_flags_p): Adjust comment. + * gcc-interface/decl.c (Has_Thiscall_Convention): Delete. + (gnat_to_gnu_entity) <E_Subprogram_Type>: Do not set the "thiscall" + attribute directly. + (is_cplusplus_method): Make static and adjust head comment. + (gnat_to_gnu_param): Return a pointer for the "this" parameter of + C++ constructors. + (gnat_to_gnu_subprog_type): Turn imported C++ constructors into their + callable form. Generate a METHOD_TYPE node for imported C++ methods. + Set param_list at the very end of the processing. + (substitute_in_type) <METHOD_TYPE>: New case. + * gcc-interface/misc.c (gnat_print_type) <METHOD_TYPE>: Likewise. + (gnat_type_hash_eq): Accept METHOD_TYPE. + * gcc-interface/trans.c (Identifier_to_gnu): Deal with METHOD_TYPE. + (Attribute_to_gnu): Likewise. + (Call_to_gnu): Likewise. + (process_freeze_entity): Likewise. + * gcc-interface/utils.c (create_subprog_decl): Adjust head comment. + (fntype_same_flags_p): Likewise. + +2018-07-17 Piotr Trojanek <trojanek@adacore.com> + + * inline.adb (Expand_Inlined_Call): Remove extra parentheses. + +2018-07-17 Eric Botcazou <ebotcazou@adacore.com> + + * exp_disp.adb (Gen_Parameters_Profile): Make the _Init parameter an + In/Out parameter. + (Set_CPP_Constructors): Adjust comment accordingly. + +2018-07-17 Bob Duff <duff@adacore.com> + + * exp_disp.adb (Build_Class_Wide_Check): Return early if the + precondition is supposed to be ignored. + +2018-07-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Check_Untagged_Equality): Extend check to operations + declared in the same scope as the operand type, when that scope is a + procedure. + +2018-07-17 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.adb (Unnest_Subprograms): Do nothing if the expander is not + active. Don't use Get_Actual_Subtype for record subtypes. Ignore + rewritten identifiers and uplevel references to bounds of types that + come from the original type reference. + +2018-07-17 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch13.adb, exp_ch7.adb, exp_unst.adb, freeze.adb, + libgnat/s-os_lib.adb, sem_ch3.adb, sem_ch3.ads, sem_ch5.adb, + sem_eval.adb, sem_res.adb, sem_util.adb: Minor reformatting. + +2018-07-17 Javier Miranda <miranda@adacore.com> + + * exp_ch13.adb (Expand_N_Freeze_Entity): Handle subtype declared for an + iterator. + * freeze.adb (Freeze_Expression): Handle freeze of an entity defined + outside of a subprogram body. This case was previously handled during + preanalysis; the frozen entities were remembered and left pending until + we continued freezeing entities outside of the subprogram. Now, when + climbing the parents chain to locate the correct placement for the + freezeing node, we check if the entity can be frozen and only when no + enclosing node is marked as Must_Not_Freeze the entity is frozen. + * sem_ch3.ads (Preanalyze_Default_Expression): Declaration moved to the + package body. + * sem_ch3.adb (Preanalyze_Default_Expression): Code adjusted to invoke + the new subprogram Preanalyze_With_Freezing_And_Resolve. + * sem_ch6.adb (Preanalyze_Formal_Expression): New subprogram. + (Analyze_Expression_Function, Process_Formals): Invoke + Preanalyze_Formal_Expression instead of Preanalyze_Spec_Expression + since the analysis of the formals may freeze entities. + (Analyze_Subprogram_Body_Helper): Skip building the body of the + class-wide clone for eliminated subprograms. + * sem_res.ads, sem_res.adb (Preanalyze_And_Resolve): New subprogram. + Its code is basically the previous version of this routine but extended + with an additional parameter which is used to specify if during + preanalysis we are allowed to freeze entities. If the new parameter is + True then the subtree root node is marked as Must_Not_Freeze and no + entities are frozen during preanalysis. + (Preanalyze_And_Resolve): Invokes the internal version of + Preanalyze_And_Resolve without entity freezing. + (Preanalyze_With_Freezing_And_Resolve): Invokes the internal version of + Prenalyze_And_Resolve with freezing enabled. + +2018-07-17 Piotr Trojanek <trojanek@adacore.com> + + * einfo.ads, libgnat/g-comlin.ads: Minor change "ie" to "i.e." in docs + and comments. + +2018-07-17 Justin Squirek <squirek@adacore.com> + + * libgnat/s-os_lib.adb (Argument_String_To_List): Fix trimming of + whitespace. + +2018-07-17 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Has_Visible_State): Do not consider constants as + visible state because it is not possible to determine whether a + constant depends on variable input. + (Propagate_Part_Of): Add comment clarifying the behavior with respect + to constant. + +2018-07-17 Yannick Moy <moy@adacore.com> + + * gnat1drv.adb (Gnat1drv): Do not issue warning about exception not + being propagated in GNATprove mode. + +2018-07-17 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/g-socket.adb, libgnat/g-socket.ads: Reorganize and make + public components of Inet_Addr_Type. Introduce public binary + operations. + +2018-07-17 Javier Miranda <miranda@adacore.com> + + * exp_ch7.adb (Make_Transient_Block): When determining whether an + enclosing scope already handles the secondary stack, take into account + transient blocks nested in a block that do not manage the secondary + stack and are located within a loop. + +2018-07-17 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Enclosing_Subprogram): Protected entries and task + entries must be treated separately: task entries are within the + enclosing subprogram of the task type, while protected entries are + transformed into the corresponding Protected_Body_Subprogram, which is + the enclosing_subprogram of any subprogram declared within the entry + body. + +2018-07-17 Hristian Kirtchev <kirtchev@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Add missing + sections on -gnatH and -gnatJ compiler switches. + * gnat_ugn.texi: Regenerate. + +2018-07-17 Hristian Kirtchev <kirtchev@adacore.com> + + * alloc.ads: Update the allocation metrics of the ignored Ghost nodes + table. + * atree.adb: Add a soft link for a procedure which is invoked whenever + an ignored Ghost node or entity is created. + (Change_Node): Preserve relevant attributes which come from the Flags + table. + (Mark_New_Ghost_Node): Record a newly created ignored Ghost node or + entity. + (Rewrite): Preserve relevant attributes which come from the Flags + table. + (Set_Ignored_Ghost_Recording_Proc): New routine. + * atree.ads: Define an access-to-suprogram type for a soft link which + records a newly created ignored Ghost node or entity. + (Set_Ignored_Ghost_Recording_Proc): New routine. + * ghost.adb: Remove with and use clause for Lib. Remove table + Ignored_Ghost_Units. Add new table Ignored_Ghost_Nodes. + (Add_Ignored_Ghost_Unit): Removed. + (Initialize): Initialize the table which stores ignored Ghost nodes. + Set the soft link which allows Atree.Mark_New_Ghost_Node to record an + ignored Ghost node. + (Is_Ignored_Ghost_Unit): Use the ultimate original node when checking + an eliminated ignored Ghost unit. + (Lock): Release and lock the table which stores ignored Ghost nodes. + (Mark_And_Set_Ghost_Assignment): Record rather than propagate ignored + Ghost nodes. + (Mark_And_Set_Ghost_Procedure_Call): Record rather than propagate + ignored Ghost nodes. + (Mark_Ghost_Clause): Record rather than propagate ignored Ghost nodes. + (Mark_Ghost_Declaration_Or_Body): Record rather than propagate ignored + Ghost nodes. + (Mark_Ghost_Pragma): Record rather than propagate ignored Ghost nodes. + (Propagate_Ignored_Ghost_Code): Removed. + (Record_Ignored_Ghost_Node): New routine. + (Remove_Ignored_Ghost_Code): Reimplemented. + (Remove_Ignored_Ghost_Node): New routine. + (Ultimate_Original_Node): New routine. + * ghost.ads (Check_Ghost_Completion): Removed. + * sem_ch8.adb (Analyze_Use_Package): Remove obsolete code. Mark a use + package clause as ignored Ghost if applicable. + * sem_util.adb (Is_Body_Or_Package_Declaration): Reimplemented. + +2018-07-17 Javier Miranda <miranda@adacore.com> + + * sem_ch5.adb (Has_Call_Using_Secondary_Stack): Moved to library level + to reuse it. + (Analyze_Loop_Statement): Wrap the loop in a block when the evaluation + of the loop iterator relies on the secondary stack. + +2018-07-17 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Next_Actual): If the parent is a N_Null_Statement, + which happens for inlined calls, then fetch the next actual from the + original AST. + +2018-07-17 Ed Schonberg <schonberg@adacore.com> + + * einfo.ads: Update documentation for Scalar_Range. + +2018-07-17 Piotr Trojanek <trojanek@adacore.com> + + * lib-xref-spark_specific.adb (Create_Heap): Attach the HEAP entity to + the Standard package. + +2018-07-17 Piotr Trojanek <trojanek@adacore.com> + + * einfo.adb (Is_Wrapper_Package): Remove extra parentheses. + +2018-07-17 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Enclosing_Subprogram): Handle properly entries, and + synchronized types that are completions of limited types or private + extensions. + (Scope_Within): Handle properly accept statements in task bodies. + +2018-07-17 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Has_Visible_State): Do not consider generic formals + because they are not part of the visible state space. Add constants to + the list of acceptable visible states. + (Propagate_Part_Of): Do not consider generic formals when propagating + the Part_Of indicator. + * sem_util.adb (Entity_Of): Do not follow renaming chains which go + through a generic formal because they are not visible for SPARK + purposes. + * sem_util.ads (Entity_Of): Update the comment on usage. + +2018-07-17 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Gather_Components): A discriminant of an ancestor may + have been constrained by a later ancestor, so when looking for the + value of that hidden discriminant we must examine the stored constraint + of other ancestors than the immediate parent type. + +2018-07-17 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb (Build_Heap_Or_Pool_Allocator): Ensure that scoping + constructs and entities within receive new entities when replicating a + tree. + (Expand_N_Extended_Return_Statement): Ensure that scoping constructs + and entities within receive new entities when replicating a tree. + * sem_util.adb (New_Copy_Tree): Add new formal Scopes_In_EWA_OK. + (Visit_Entity): Visit entities within scoping constructs inside + expression with actions nodes when requested by the caller. Add blocks, + labels, and procedures to the list of entities which need replication. + * sem_util.ads (New_Copy_Tree): Add new formal Scopes_In_EWA_OK. Update + the comment on usage. + +2018-07-17 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_ugn/about_this_guide.rst, + doc/gnat_ugn/gnat_and_program_execution.rst: Remove references to gcov. + * gnat_ugn.texi: Regenerate. + +2018-07-16 Hristian Kirtchev <kirtchev@adacore.com> + + * contracts.adb (Analyze_Contracts): Add specialized processing for + package instantiation contracts. + (Analyze_Package_Contract): Remove the verification of a missing + Part_Of indicator. + (Analyze_Package_Instantiation_Contract): New routine. + * contracts.ads (Analyze_Package_Contract): Update the comment on + usage. + * sem_prag.adb (Check_Missing_Part_Of): Ensure that the entity of the + instance is being examined when trying to determine whether a package + instantiation needs a Part_Of indicator. + +2018-07-16 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb, exp_ch7.adb, exp_ch9.adb, exp_unst.adb, inline.adb, + sem.adb, sem_ch12.adb, sem_ch13.adb, sem_ch3.adb, sem_eval.adb, + sem_util.adb: Minor reformatting. + +2018-07-16 Arnaud Charlet <charlet@adacore.com> + + * frontend.adb: Only unnest subprograms if no previous errors were + detected. + +2018-07-16 Ed Schonberg <schonberg@adacore.com> + + * exp_ch7.adb (Check_Unnesting_Elaboration_Code): Handle loops that + contain blocks in the elaboration code for a package body. Create the + elaboration subprogram wrapper only if there is a subprogram + declaration in a block or loop. + +2018-07-16 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Expand_Set_Membership): Use New_Copy_Tree to perform a + deep copy of the left operand when building each conjuct of the + expanded membership operation, to avoid sharing nodes between them. + This sharing interferes with the unnesting machinery and is generally + undesirable. + +2018-07-16 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.adb (Visit_Node): Handle 'Address references that are + calls. + +2018-07-16 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.adb (Visit_Node): Handle the semantic of Storage_Pool field + in relevant nodes: Allocate, Free, and return statements. + +2018-07-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Analyze_Package_Instantiation): Handle properly an + instance that carries an aspect Default_Storage_Pool that overrides a + default storage pool that applies to the generic unit. The aspect in + the generic unit was removed before copying it in the instance, rather + than removing it from the copy of the aspects that are appended to the + aspects in the instance. + +2018-07-16 Ed Schonberg <schonberg@adacore.com> + + * einfo.adb (Set_Is_Uplevel_Referenced_Entity): Flag can appear on + loop parameters. + * exp_ch7.adb (Check_Unnesting_Elaboration_Code): Handle subprogram + bodies. + * exp_ch9.adb (Reset_Scopes_To): Set the scopes of entities local to an + entry body to be the corresponding generated subprogram, for correct + analysis of uplevel references. + * exp_unst.adb (Visit_Node): Handle properly binary and unary operators + Ignore pragmas, fix component associations. + (Register_Subprograms): Subprograms in synchronized types must be + treated as reachable. + +2018-07-16 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_util.adb (Check_No_Hidden_State): Ignore internally-generated + states and variables. + +2018-07-16 Piotr Trojanek <trojanek@adacore.com> + + * sinfo.ads, sinfo.adb (Withed_Body): Remove. + (Set_Withed_Body): Remove. + +2018-07-16 Piotr Trojanek <trojanek@adacore.com> + + * sem.adb (Walk_Library_Items): Skip units with configuration pragmas + when printing debug info. + +2018-07-16 Piotr Trojanek <trojanek@adacore.com> + + * sem.adb (Walk_Library_Items): Reuse local constant. + (Is_Subunit_Of_Main): Turn condition to positive and flip the + IF-THEN-ELSE branches; avoid potentially ineffective assignment to the + Lib variable. + +2018-07-16 Piotr Trojanek <trojanek@adacore.com> + + * sem.adb (Walk_Library_Items): Deconstruct dead code. + +2018-07-16 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Expand_N_Op_Xor): Use common routine + Expand_Nonbinary_Modular_Op. Needed for unnesting. + +2018-07-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Inherit_Predicate_Flags): A non-discrete type may have a + static predicate (for example True) but has no + static_discrete_predicate. + +2018-07-16 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_attr.adb (Build_Record_VS_Func): Handle corner cases dealing with + class-wide types and record extensions. + +2018-07-16 Justin Squirek <squirek@adacore.com> + + * sem_eval.adb (Eval_Integer_Literal): Add exception for avoiding + checks on expanded literals within if and case expressions. + +2018-07-16 Hristian Kirtchev <kirtchev@adacore.com> + + * libgnat/s-wchwts.adb (Wide_String_To_String): Use the appropriate + longest sequence factor. Code clean up. + (Wide_Wide_String_To_String): Use the appropriate longest sequence + factor. Code clean up. + +2018-07-16 Javier Miranda <miranda@adacore.com> + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Report an error + on Bit_Order when defined for a record extension. + +2018-07-16 Arnaud Charlet <charlet@adacore.com> + + * libgnat/s-objrea.ads: Minor code clean up. + +2018-07-16 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Process_Discriminants): Adjust reference to the SPARM RM + rule. + +2018-07-16 Arnaud Charlet <charlet@adacore.com> + + * adaint.c (__gnat_set_file_time_name): Code clean up. + +2018-07-16 Javier Miranda <miranda@adacore.com> + + * inline.adb (Build_Body_To_Inline): Minor code reorganization that + ensures that calls to function Has_Single_Return() pass a decorated + tree. + (Has_Single_Return.Check_Return): Peform checks on entities (instead on + relying on their characters). + +2018-07-16 Javier Miranda <miranda@adacore.com> + + * exp_ch5.adb (Expand_Iterator_Loop_Over_Array): Code cleanup. Required + to avoid generating an ill-formed tree that confuses gnatprove causing + it to blowup. + +2018-07-16 Yannick Moy <moy@adacore.com> + + * inline.adb (Has_Single_Return): Rewrap comment. + +2018-07-16 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads: Minor tweak in comment. + +2018-07-16 Javier Miranda <miranda@adacore.com> + + * sem_ch4.adb (Analyze_Membership_Op): Code cleanup. + +2018-07-16 Javier Miranda <miranda@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference ['Count]): Do not + transform 'Count into a function call if the current scope has been + eliminated. + +2018-07-16 Javier Miranda <miranda@adacore.com> + + * sem_util.ads, sem_util.adb (Has_Prefix): Move this function to the + public part of this package. + +2018-07-16 Yannick Moy <moy@adacore.com> + + * sem_res.adb (Resolve_Call): Do not inline calls inside + compiler-generated functions translated as predicates in GNATprove. + +2018-07-16 Gary Dismukes <dismukes@adacore.com> + + * exp_ch4.adb (Expand_N_Allocator): Test for Storage_Pool being RTE in + addition to the existing test for no Storage_Pool as a condition + enabling generation of the call to Check_Standard_Allocator when the + restriction No_Standard_Allocators_After_Elaboration is active. + * libgnat/s-elaall.ads (Check_Standard_Allocator): Correct comment to + say that Storage_Error will be raised (rather than Program_Error). + * libgnat/s-elaall.adb (Check_Standard_Allocator): Raise Storage_Error + rather than Program_Error when Elaboration_In_Progress is False. + +2018-07-16 Gary Dismukes <dismukes@adacore.com> + + * sem_eval.adb: Fix spelling for compile-time-known. + +2018-07-16 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_eval.adb (Compile_Time_Known_Value): Add a guard which prevents + the compiler from entering infinite recursion when trying to determine + whether a deferred constant has a compile time known value, and the + initialization expression of the constant is a reference to the + constant itself. + +2018-07-16 Nicolas Roche <roche@adacore.com> + + * libgnat/a-strunb.adb, libgnat/a-strunb__shared.adb: Adjust growth + factor from 1/32 to 1/2 for Unbounded_String. + +2018-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/lang.opt (funsigned-char): New option. + * gcc-interface/misc.c (gnat_handle_option): Accept it. + * gcc-interface/utils.c (finish_character_type): Tweak comment. + +2018-07-07 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity): Add GNAT_DECL local + variable and use it throughout. + <E_Variable>: If the nominal subtype of the object is unconstrained, + compute the Ada size separately and put in on the padding type if the + size is not fixed. + <E_Record_Type>: Minor tweak. + * gcc-interface/misc.c (gnat_type_max_size): Rename max_size_unit + into max_size_unit throughout. + +2018-07-07 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/gigi.h (add_decl_expr): Adjust prototype. + * gcc-interface/decl.c (gnat_to_gnu_entity): Remove useless test. + * gcc-interface/trans.c (add_stmt_with_node): Remove exceptions. + (add_decl_expr): Change type of second parameter and rename it. + (renaming_from_instantiation_p): New function moved from... + (set_expr_location_from_node): Test for exceptions here and add one + for actual subtypes built for unconstrained composite actuals. + * gcc-interface/utils.c (renaming_from_instantiation_p): ...here. + +2018-07-07 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (lvalue_required_p): Remove ALIASED parameter + and adjust recursive calls. + (Identifier_to_gnu): Adjust calls to lvalue_required_p. + (gnat_to_gnu): Likewise. + +2018-07-07 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_param): Minor tweak. + (gnat_to_gnu_subprog_type): New pure_flag local variable. Set it for + a pure Ada function with a by-ref In parameter. Propagate it onto the + function type by means of the TYPE_QUAL_RESTRICT flag. + * gcc-interface/utils.c (finish_subprog_decl): Set DECL_PURE_P if the + function type has the TYPE_QUAL_RESTRICT flag set. + +2018-07-06 Jim Wilson <jimw@sifive.com> + + * Makefile.rtl: Add riscv*-linux* support. + * libgnarl/s-linux__riscv.ads: New. + * libgnat/system-linux-riscv.ads: New. + + * Make-generated.in (treeprs.ads): Use $(GNATMAKE) instead of gnatmake. + (einfo.h, sinfo.h, stamp-snames, stamp-nmake): Likewise. + * gcc-interface/Makefile.in (xoscons): Likewise. + +2018-07-06 Sebastian Huber <sebastian.huber@embedded-brains.de> + + * libgnat/system-rtems.ads (Frontend_Exceptions): Set to False. + (ZCX_By_Default): Set to True. + +2018-07-02 Martin Liska <mliska@suse.cz> + + * gnatvsn.ads: Bump Library_Version to 9. + +2018-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/ada-tree.h (TYPE_RETURN_BY_DIRECT_REF_P): Change from + using TYPE_LANG_FLAG_4 to using TYPE_LANG_FLAG_0. + (TYPE_ALIGN_OK): Move around. + (TYPE_PADDING_FOR_COMPONENT): Remove superfluous parentheses. + * gcc-interface/decl.c (change_qualified_type): Move to... + (gnat_to_gnu_entity): Adjust comment. + * gcc-interface/gigi.h (change_qualified_type): ...here; make inline. + (ceil_pow2): Use ceil_log2. + * gcc-interface/utils.c (finish_subprog_decl): Add couple of comments + and do not set TREE_SIDE_EFFECTS. + (handle_noreturn_attribute): Use change_qualified_type. + +2018-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Constant>: Do not get + the expression of a dispatch table that is not being defined. + <E_Record_Subtype>: Remove obsolete kludge. + +2018-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (warn_on_field_placement): Use specific wording + for discriminants. + (warn_on_list_placement): New static function. + (components_to_record): Use it to warn on multiple fields in list. + +2018-06-12 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (variant_desc): Add AUX field. + (gnat_to_gnu_entity) <discrete_type>: Do not call compute_record_mode + directly. + (reverse_sort_field_list): New static function. + (components_to_record): Place the variant part at the beginning of the + field list when there is an obvious order of increasing position. + (build_variant_list): Initialize it. + (create_variant_part_from): Do not call compute_record_mode directly. + (copy_and_substitute_in_layout): Likewise. Always sort the fields with + fixed position in order of increasing position, in the record and all + the variants, in any. Call reverse_sort_field_list. + * gcc-interface/utils.c (make_packable_type): Compute the sizes before + calling finish_record_type. Do not call compute_record_mode directly. + (finish_record_type): Overhaul final processing depending on REP_LEVEL + and call finish_bitfield_layout if it is equal to one or two. + +2018-06-11 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Type>: Reuse the + existing fields of a dummy fat pointer type, if any. Clear the + TYPE_DECL_SUPPRESS_DEBUG on the fat pointer type after completing it. + +2018-06-11 Hristian Kirtchev <kirtchev@adacore.com> + + * contracts.adb (Process_Body_Postconditions): Expand only checked + postconditions. + (Process_Contract_Cases_For): Expand only checked contract cases. + (Process_Inherited_Preconditions): Ignored class-wide preconditions are + partially expanded because some of their semantic checks are tied to + the expansion. + (Process_Preconditions_For): Expand only checked preconditions. + (Process_Spec_Postconditions): Expand only checked preconditions. + Ignored class-wide preconditions are partially expanded because some of + their semantic checks are tied to the expansion. + * exp_prag.adb (Expand_N_Pragma): Suppress the expansion of ignored + assertion pragmas. + * exp_util.adb (Add_Inherited_Invariants): Code clean up. + * sem_util.adb (Propagate_Invariant_Attributes): Code clean up. + +2018-06-11 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch9.adb, exp_unst.adb, inline.adb, libgnat/a-ciorma.adb, + libgnat/a-ciormu.adb, libgnat/a-ciorse.adb, libgnat/a-coorma.adb, + libgnat/a-coormu.adb, libgnat/a-coorse.adb, sem_prag.adb: Minor + reformatting. + +2018-06-11 Gary Dismukes <dismukes@adacore.com> + + * exp_unst.ads, exp_unst.adb: Typo fixes and minor reformatting. + +2018-06-11 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb (Add_Unconstrained_Actuals_To_Build_In_Place_Call): Do + not add any actuals when the size of the object is known, and the + caller will allocate it. + (Build_Heap_Allocator): Rename to Build_Heap_Or_Pool_Allocator to + better illustrate its functionality. Update the comment on the + generated code. Generate a branch for the heap and pool cases where + the object is not necessarity controlled. + (Expand_N_Extended_Return_Statement): Expand the extended return + statement into four branches depending the requested mode if the caller + will not allocate the object on its side. + (Make_Build_In_Place_Call_In_Allocator): Do not allocate a controlled + object on the caller side because this will violate the semantics of + finalizable types. Instead notify the function to allocate the object + on the heap or a user-defined storage pool. + (Needs_BIP_Alloc_Form): A build-in-place function needs to be notified + which of the four modes to employ when returning a limited controlled + result. + * exp_util.adb (Build_Allocate_Deallocate_Proc): Remove a redundant + guard which is already covered in Needs_Finalization. + +2018-06-11 Olivier Hainque <hainque@adacore.com> + + * libgnat/s-excmac*.ads: Factorize Unwind_Action definitions ... + * libgnat/a-exexpr.adb: ... Here, then add comments describing the + major datastructures associated with the current exception raised. + (Setup_Current_Excep): Accept a "Phase" argument conveying the + unwinding phase during which this subprogram is called. For an Ada + exception, don't update the current exception buffer from the raised + exception object during SEARCH_PHASE, as this is redundant with the + call now issued just before propagation starts. + (Propagate_GCC_Exception): Move call to Setup_Current_Excep ahead of + the unwinding start, conveying Phase 0. + (Unhandled_Except_Handler): Pass UA_CLEANUP_PHASE as the Phase value on + the call to Setup_Current_Excep. + * raise-gcc.c (personality_body): Pass uw_phases as the Phase argument + on calls to Setup_Current_Excep. + +2018-06-11 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.ads, exp_unst.adb (Needs_Fat_Pointer, + Build_Access_Type_Decl): New subprograms to handle uplevel references + to formals of an unconstrained array type. The activation record + component for these is an access type, and the reference is rewritten + as an explicit derefenrence of that component. + +2018-06-11 Bob Duff <duff@adacore.com> + + * libgnat/a-ciorma.adb, libgnat/a-ciormu.adb, libgnat/a-ciorse.adb, + libgnat/a-coorma.adb, libgnat/a-coormu.adb, libgnat/a-coorse.adb: + (Element): Add code to detect dangling cursors in some cases. + +2018-06-11 Yannick Moy <moy@adacore.com> + + * sem_ch6.adb (Build_Subprogram_Declaration): Mark parameters as coming + from source. + +2018-06-11 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Build_Predicate_Functions): For a derived type, ensure + that its parent is already frozen so that its predicate function, if + any, has already been constructed. + +2018-06-11 Yannick Moy <moy@adacore.com> + + * sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context): Adapt for + possible task unit as the enclosing context. + +2018-06-11 Eric Botcazou <ebotcazou@adacore.com> + + * gnat1drv.adb: Remove use clause for Repinfo. + (Gnat1drv): Beef up comment about the interplay between -gnatc and + back-end annotations. Use full qualified name for List_Rep_Info. + +2018-06-11 Hristian Kirtchev <kirtchev@adacore.com> + + * libgnat/g-arrspl.ads: Add pragma Preelaborate. + +2018-06-11 Arnaud Charlet <charlet@adacore.com> + + * exp_ch4.adb (Expand_Record_Equality): Remove extraneous "True and + then" and general logical "ada" in codepeer mode. + +2018-06-11 Javier Miranda <miranda@adacore.com> + + * exp_ch9.adb (Expand_N_Protected_Body): Add missing handling of + N_Call_Marker nodes. + +2018-06-11 Arnaud Charlet <charlet@adacore.com> + + * exp_ch3.adb, exp_unst.adb, inline.adb, sem_prag.adb: Minor + reformatting. + +2018-06-11 Yannick Moy <moy@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: Add Suppressible + argument to Assertion_Policy + * gnat_rm.texi: Regenerate. + +2018-06-11 Yannick Moy <moy@adacore.com> + + * gnat1drv.adb: Do not check representation information in CodePeer and + GNATprove modes, as these modes call a special backend instead of gigi, + so do not have the information. + +2018-06-11 Yannick Moy <moy@adacore.com> + + * inline.adb (Build_Body_To_Inline): Consider case of extended return + of unconstrained type as one case where inlining is not supported. + (Expand_Inlined_Call): Remove special case for body as extended return + of unconstrained type. + +2018-06-11 Yannick Moy <moy@adacore.com> + + * sem_prag.adb (Analyze_Part_Of): Only allow Part_Of on non-generic + unit. + (Check_Missing_Part_Of): Do not force Part_Of on generic unit. + +2018-06-11 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Don't split AND THEN + expressions in Pre/Post contracts while in GNATprove_Mode. + +2018-06-11 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Is_Potentially_Unevaluated): Fix detection of contracts + with AND THEN expressions broken down into individual conjuncts. + +2018-06-11 Ed Schonberg <schonberg@adacore.com> + + * exp_ch7.adb (Check_Unnesting_Elaboration_Code): Add guard. + +2018-06-11 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.adb (Visit_Node): Skip generic associations. + +2018-06-11 Arnaud Charlet <charlet@adacore.com> + + * libgnat/memtrack.adb (fwrite): Remove second definition. + +2018-06-11 Javier Miranda <miranda@adacore.com> + + * sinfo.ads (Is_Dynamic_Coextension): Adding documentation. + (Is_Static_Coextension): Adding documentation. + * sinfo.adb (Is_Dynamic_Coextension): Extending the assertion. + (Is_Static_Coextension): Extending the assertion. + * sem_util.adb (Mark_Allocator): Clear Is_Static_Coextension when + setting flag Is_Dynamic_Coextension (and vice versa). + +2018-06-11 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.adb (Search_Subprograms): Handle explicitly stubs at the top + level of a compilation unit, becuase they may contain nested + subprograms that need an activation record. + +2018-06-11 Arnaud Charlet <charlet@adacore.com> + + * Makefile.rtl: Compile Ada files with $(ADAC) instead of $(CC). + +2018-06-11 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch11.adb, exp_unst.adb, inline.adb, sem_ch12.adb, sem_util.adb: + Minor reformatting. + * sinfo.ads: Fix a typo. + +2018-06-11 Ed Schonberg <schonberg@adacore.com> + + * inline.adb (Expand_Inlined_Call): If no optimization level is + specified, the expansion of a call to an Inline_Always function is + fully performed in the front-end even on a target that support back-end + inlining. + +2018-06-11 Arnaud Charlet <charlet@adacore.com> + + * bindgen.adb (Gen_Adainit): Protect reference to System.Parameters + with Sec_Stack_Used. + +2018-06-11 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch8.adb (Find_Direct_Name): Mode the declaration of + Is_Assignment_LHS further in. Use predicate + Needs_Variable_Reference_Marker to determine whether to create a + variable marker. + (Find_Expanded_Name): Mode the declaration of Is_Assignment_LHS further + in. Use predicate Needs_Variable_Reference_Marker to determine whether + to create a variable marker. + * sem_elab.adb (Build_Variable_Reference_Marker): Remove the various + checks that determine whether the identifier or expanded name is a + suitable variable reference. The checks are now performed by + Needs_Variable_Reference_Marker. + * sem_res.adb (Resolve_Actuals): Use predicate + Needs_Variable_Reference_Marker to determine whether to create a + variable marker. + * sem_util.adb (Needs_Variable_Reference_Marker): New routine. + * sem_util.ads (Needs_Variable_Reference_Marker): New routine. + +2018-06-11 Valentine Reboul <reboul@adacore.com> + + * doc/gnat_rm.rst, doc/gnat_ugn.rst: Rename "GPL Edition" into + "Community Edition". + +2018-06-11 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Install_Body): In order to determine the placement of + the freeze node for an instance of a generic nested within another + instance, take into account that the outer instance may be declared in + the visible part of a package and the inner intance may be in the + private part of the same package. + +2018-06-11 Eric Botcazou <ebotcazou@adacore.com> + + * errout.adb (Special_Msg_Delete): Remove handling of Atomic and VFA. + +2018-06-11 Nicolas Roche <roche@adacore.com> + + * libgnat/s-valuti.adb (Bad_Value): Ensure that we do not generate a + stack overflow while raising a constraint error. + +2018-06-11 Eric Botcazou <ebotcazou@adacore.com> + + * repinfo.ads (Rep_Value): Use a single line. + * repinfo.adb (Rep_Value): Likewise. + (List_Attr): Do not use string concatenation. + +2018-06-11 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.adb (Visit_Node): Check reference to formal parameter of + current procedure, because the bounds of its type may be uplevel + references. + 2018-06-02 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Constant>: If this is @@ -1984,7 +3093,7 @@ 2018-05-21 Jerome Lambourg <lambourg@adacore.com> * gcc-interface/Makefile.in: Add g-soliop__qnx.ads to the runtime build - for QNX. + for QNX. 2018-05-21 Hristian Kirtchev <kirtchev@adacore.com> diff --git a/gcc/ada/Make-generated.in b/gcc/ada/Make-generated.in index 757eaa8..bdcb62c 100644 --- a/gcc/ada/Make-generated.in +++ b/gcc/ada/Make-generated.in @@ -28,21 +28,21 @@ $(ADA_GEN_SUBDIR)/treeprs.ads : $(ADA_GEN_SUBDIR)/treeprs.adt $(ADA_GEN_SUBDIR)/ -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/treeprs $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/treeprs/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/treeprs - (cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; gnatmake -q xtreeprs ; ./xtreeprs treeprs.ads ) + (cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; $(GNATMAKE) -q xtreeprs ; ./xtreeprs treeprs.ads ) $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/treeprs/treeprs.ads $(ADA_GEN_SUBDIR)/treeprs.ads $(ADA_GEN_SUBDIR)/einfo.h : $(ADA_GEN_SUBDIR)/einfo.ads $(ADA_GEN_SUBDIR)/einfo.adb $(ADA_GEN_SUBDIR)/xeinfo.adb $(ADA_GEN_SUBDIR)/ceinfo.adb -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/einfo $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/einfo/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/einfo - (cd $(ADA_GEN_SUBDIR)/bldtools/einfo; gnatmake -q xeinfo ; ./xeinfo einfo.h ) + (cd $(ADA_GEN_SUBDIR)/bldtools/einfo; $(GNATMAKE) -q xeinfo ; ./xeinfo einfo.h ) $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/einfo/einfo.h $(ADA_GEN_SUBDIR)/einfo.h $(ADA_GEN_SUBDIR)/sinfo.h : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/sinfo.adb $(ADA_GEN_SUBDIR)/xsinfo.adb $(ADA_GEN_SUBDIR)/csinfo.adb -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/sinfo $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/sinfo/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/sinfo - (cd $(ADA_GEN_SUBDIR)/bldtools/sinfo; gnatmake -q xsinfo ; ./xsinfo sinfo.h ) + (cd $(ADA_GEN_SUBDIR)/bldtools/sinfo; $(GNATMAKE) -q xsinfo ; ./xsinfo sinfo.h ) $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/sinfo/sinfo.h $(ADA_GEN_SUBDIR)/sinfo.h $(ADA_GEN_SUBDIR)/snames.h $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb : $(ADA_GEN_SUBDIR)/stamp-snames ; @true @@ -50,7 +50,7 @@ $(ADA_GEN_SUBDIR)/stamp-snames : $(ADA_GEN_SUBDIR)/snames.ads-tmpl $(ADA_GEN_SUB -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/snamest $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/snamest/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/snamest - (cd $(ADA_GEN_SUBDIR)/bldtools/snamest; gnatmake -q xsnamest ; ./xsnamest ) + (cd $(ADA_GEN_SUBDIR)/bldtools/snamest; $(GNATMAKE) -q xsnamest ; ./xsnamest ) $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.ns $(ADA_GEN_SUBDIR)/snames.ads $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nb $(ADA_GEN_SUBDIR)/snames.adb $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nh $(ADA_GEN_SUBDIR)/snames.h @@ -61,7 +61,7 @@ $(ADA_GEN_SUBDIR)/stamp-nmake: $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nma -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/nmake $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/nmake/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/nmake - (cd $(ADA_GEN_SUBDIR)/bldtools/nmake; gnatmake -q xnmake ; ./xnmake -b nmake.adb ; ./xnmake -s nmake.ads) + (cd $(ADA_GEN_SUBDIR)/bldtools/nmake; $(GNATMAKE) -q xnmake ; ./xnmake -b nmake.adb ; ./xnmake -s nmake.ads) $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.ads $(ADA_GEN_SUBDIR)/nmake.ads $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.adb $(ADA_GEN_SUBDIR)/nmake.adb touch $(ADA_GEN_SUBDIR)/stamp-nmake diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 34988c8..7eaa9ba 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -17,11 +17,14 @@ #along with GCC; see the file COPYING3. If not see #<http://www.gnu.org/licenses/>. -# This makefile fragment is included in the ada Makefile (both Unix -# and Windows). +# This makefile fragment is included in the ada Makefile. -# Its purpose is to allow the separate maintainence of the list of -# GNATRTL objects, which frequently changes. +# Its purpose is to allow the separate maintenance of the list of +# GNATRTL objects and target pairs, which frequently changes. + +ifndef ADAC +ADAC=$(CC) +endif # Objects needed only for tasking GNATRTL_TASKING_OBJS= \ @@ -1957,19 +1960,17 @@ endif # Cygwin/Mingw32 ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),) # Cygwin provides a full Posix environment, and so we use the default - # versions of s-memory and g-socthi rather than the Windows-specific - # MinGW versions. Ideally we would use all the default versions for - # Cygwin and none of the MinGW versions, but for historical reasons - # the Cygwin port has always been a CygMing frankenhybrid and it is - # a long-term project to disentangle them. + # versions g-socthi rather than the Windows-specific MinGW version. + # Ideally we would use all the default versions for Cygwin and none + # of the MinGW versions, but for historical reasons the Cygwin port + # has always been a CygMing frankenhybrid and it is a long-term project + # to disentangle them. ifeq ($(strip $(filter-out cygwin%,$(target_os))),) LIBGNAT_TARGET_PAIRS = \ - s-memory.adb<libgnat/s-memory.adb \ g-socthi.ads<libgnat/g-socthi.ads \ g-socthi.adb<libgnat/g-socthi.adb else LIBGNAT_TARGET_PAIRS = \ - s-memory.adb<libgnat/s-memory__mingw.adb \ g-socthi.ads<libgnat/g-socthi__mingw.ads \ g-socthi.adb<libgnat/g-socthi__mingw.adb endif @@ -2465,6 +2466,34 @@ ifeq ($(strip $(filter-out %x32 linux%,$(target_cpu) $(target_os))),) LIBRARY_VERSION := $(LIB_VERSION) endif +# RISC-V Linux +ifeq ($(strip $(filter-out riscv% linux%,$(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__posix.adb \ + s-linux.ads<libgnarl/s-linux__riscv.ads \ + s-osinte.adb<libgnarl/s-osinte__posix.adb \ + s-osinte.ads<libgnarl/s-osinte__linux.ads \ + s-osprim.adb<libgnat/s-osprim__posix.adb \ + s-taprop.adb<libgnarl/s-taprop__linux.adb \ + s-tasinf.ads<libgnarl/s-tasinf__linux.ads \ + s-tasinf.adb<libgnarl/s-tasinf__linux.adb \ + s-taspri.ads<libgnarl/s-taspri__posix-noaltstack.ads \ + s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \ + g-sercom.adb<libgnat/g-sercom__linux.adb \ + system.ads<libgnat/system-linux-riscv.ads + + TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb + + EXTRA_GNATRTL_TASKING_OBJS=s-linux.o + EH_MECHANISM=-gcc + THREADSLIB = -lpthread + GNATLIB_SHARED = gnatlib-shared-dual + GMEM_LIB = gmemlib + LIBRARY_VERSION := $(LIB_VERSION) +endif + # Darwin (Mac OS X) ifeq ($(strip $(filter-out darwin%,$(target_os))),) SO_OPTS = -shared-libgcc @@ -2682,15 +2711,16 @@ setup-rts: force # optimization. We don't want inlining, either. s-traceb.o : s-traceb.adb s-traceb.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(NO_INLINE_ADAFLAGS) \ - $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) \ + $(NO_INLINE_ADAFLAGS) $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) $< \ + $(OUTPUT_OPTION) # compile s-tasdeb.o without optimization and with debug info so that it is # always possible to set conditional breakpoints on tasks. s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ - $< $(OUTPUT_OPTION) + $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) # force no function reordering on a-except.o because of the exclusion bounds # mechanism (see the source file for more detailed information). @@ -2699,35 +2729,36 @@ s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads # use -O1 otherwise gdb isn't able to get a full backtrace on mips targets. a-except.o : a-except.adb a-except.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(NO_INLINE_ADAFLAGS) \ - $(NO_REORDER_ADAFLAGS) -O1 $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) \ + $(NO_INLINE_ADAFLAGS) $(NO_REORDER_ADAFLAGS) -O1 $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) # compile s-excdeb.o without optimization and with debug info to let the # debugger set breakpoints and inspect subprogram parameters on exception # related events. s-excdeb.o : s-excdeb.adb s-excdeb.ads s-except.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ - $< $(OUTPUT_OPTION) + $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ + $(ADA_INCLUDES) $< $(OUTPUT_OPTION) # force debugging information on s-assert.o so that it is always # possible to set breakpoint on assert failures. s-assert.o : s-assert.adb s-assert.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ - $< $(OUTPUT_OPTION) + $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) # force debugging information on a-tags.o so that the debugger can find # the description of Ada.Tags.Type_Specific_Data. a-tags.o : a-tags.adb a-tags.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ - $< $(OUTPUT_OPTION) + $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) # force no sibling call optimization on s-memory.o to avoid turning the # tail recursion in Alloc into a loop that confuses branch prediction. s-memory.o : s-memory.adb s-memory.ads - $(CC) -c $(ALL_ADAFLAGS) $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \ - $< $(OUTPUT_OPTION) + $(ADAC) -c $(ALL_ADAFLAGS) $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \ + $< $(OUTPUT_OPTION) diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 552bd44..2bd033a 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -1475,7 +1475,7 @@ __gnat_set_file_time_name (char *name, time_t time_stamp) utimbuf.modtime = time_stamp; /* Set access time to now in local time. */ - t = time ((time_t) 0); + t = time (NULL); utimbuf.actime = mktime (localtime (&t)); utime (name, &utimbuf); diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 1cb454c..48b5715 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -39,7 +39,7 @@ package body ALI is -- line type markers in the ALI file. This is used in Scan_ALI to detect -- (or skip) invalid lines. The following letters are still available: -- - -- B G H J K O Q Z + -- B F G H J K O Q Z Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean := ('V' => True, -- version @@ -59,7 +59,6 @@ package body ALI is 'Y' => True, -- limited_with 'Z' => True, -- implicit with from instantiation 'C' => True, -- SCO information - 'F' => True, -- SPARK cross-reference information 'T' => True, -- task stack information others => False); diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads index b219846..96e67ed 100644 --- a/gcc/ada/alloc.ads +++ b/gcc/ada/alloc.ads @@ -67,8 +67,8 @@ package Alloc is In_Out_Warnings_Initial : constant := 100; -- Sem_Warn In_Out_Warnings_Increment : constant := 100; - Ignored_Ghost_Units_Initial : constant := 20; -- Sem_Util - Ignored_Ghost_Units_Increment : constant := 50; + Ignored_Ghost_Nodes_Initial : constant := 100; -- Ghost + Ignored_Ghost_Nodes_Increment : constant := 100; Inlined_Initial : constant := 100; -- Inline Inlined_Increment : constant := 100; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 958cd51..c788977 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -48,6 +48,10 @@ with GNAT.Heap_Sort_G; package body Atree is + Ignored_Ghost_Recording_Proc : Ignored_Ghost_Record_Proc := null; + -- This soft link captures the procedure invoked during the creation of an + -- ignored Ghost node or entity. + Locked : Boolean := False; -- Compiling with assertions enabled, node contents modifications are -- permitted only when this switch is set to False; compiling without @@ -683,12 +687,21 @@ package body Atree is ----------------- procedure Change_Node (N : Node_Id; New_Node_Kind : Node_Kind) is - Save_Sloc : constant Source_Ptr := Sloc (N); + + -- Flags table attributes + + Save_CA : constant Boolean := Flags.Table (N).Check_Actuals; + Save_Is_IGN : constant Boolean := Flags.Table (N).Is_Ignored_Ghost_Node; + + -- Nodes table attributes + + Save_CFS : constant Boolean := Nodes.Table (N).Comes_From_Source; Save_In_List : constant Boolean := Nodes.Table (N).In_List; Save_Link : constant Union_Id := Nodes.Table (N).Link; - Save_CFS : constant Boolean := Nodes.Table (N).Comes_From_Source; Save_Posted : constant Boolean := Nodes.Table (N).Error_Posted; - Par_Count : Nat := 0; + Save_Sloc : constant Source_Ptr := Sloc (N); + + Par_Count : Nat := 0; begin if Nkind (N) in N_Subexpr then @@ -703,7 +716,9 @@ package body Atree is Nodes.Table (N).Nkind := New_Node_Kind; Nodes.Table (N).Error_Posted := Save_Posted; - Flags.Table (N) := Default_Flags; + Flags.Table (N) := Default_Flags; + Flags.Table (N).Check_Actuals := Save_CA; + Flags.Table (N).Is_Ignored_Ghost_Node := Save_Is_IGN; if New_Node_Kind in N_Subexpr then Set_Paren_Count (N, Par_Count); @@ -1606,6 +1621,13 @@ package body Atree is end if; Set_Is_Ignored_Ghost_Node (N); + + -- Record the ignored Ghost node or entity in order to eliminate it + -- from the tree later. + + if Ignored_Ghost_Recording_Proc /= null then + Ignored_Ghost_Recording_Proc.all (N); + end if; end if; end Mark_New_Ghost_Node; @@ -1629,8 +1651,8 @@ package body Atree is if Source > Empty_Or_Error then New_Id := Allocate_Initialize_Node (Source, Has_Extension (Source)); - Nodes.Table (New_Id).Link := Empty_List_Or_Node; Nodes.Table (New_Id).In_List := False; + Nodes.Table (New_Id).Link := Empty_List_Or_Node; -- If the original is marked as a rewrite insertion, then unmark the -- copy, since we inserted the original, not the copy. @@ -2164,7 +2186,7 @@ package body Atree is -- If the node being relocated was a rewriting of some original node, -- then the relocated node has the same original node. - if Orig_Nodes.Table (Source) /= Source then + if Is_Rewrite_Substitution (Source) then Orig_Nodes.Table (New_Node) := Orig_Nodes.Table (Source); end if; @@ -2218,16 +2240,24 @@ package body Atree is ------------- procedure Rewrite (Old_Node, New_Node : Node_Id) is - Old_Error_P : constant Boolean := Nodes.Table (Old_Node).Error_Posted; - -- This field is always preserved in the new node - Old_Has_Aspects : constant Boolean := Nodes.Table (Old_Node).Has_Aspects; - -- This field is always preserved in the new node + -- Flags table attributes + + Old_CA : constant Boolean := Flags.Table (Old_Node).Check_Actuals; + Old_Is_IGN : constant Boolean := + Flags.Table (Old_Node).Is_Ignored_Ghost_Node; + + -- Nodes table attributes + + Old_Error_Posted : constant Boolean := + Nodes.Table (Old_Node).Error_Posted; + Old_Has_Aspects : constant Boolean := + Nodes.Table (Old_Node).Has_Aspects; - Old_Paren_Count : Nat; Old_Must_Not_Freeze : Boolean; - -- These fields are preserved in the new node only if the new node - -- and the old node are both subexpression nodes. + Old_Paren_Count : Nat; + -- These fields are preserved in the new node only if the new node and + -- the old node are both subexpression nodes. -- Note: it is a violation of abstraction levels for Must_Not_Freeze -- to be referenced like this. ??? @@ -2244,11 +2274,11 @@ package body Atree is pragma Debug (New_Node_Debugging_Output (New_Node)); if Nkind (Old_Node) in N_Subexpr then - Old_Paren_Count := Paren_Count (Old_Node); Old_Must_Not_Freeze := Must_Not_Freeze (Old_Node); + Old_Paren_Count := Paren_Count (Old_Node); else - Old_Paren_Count := 0; Old_Must_Not_Freeze := False; + Old_Paren_Count := 0; end if; -- Allocate a new node, to be used to preserve the original contents @@ -2274,9 +2304,12 @@ package body Atree is -- Copy substitute node into place, preserving old fields as required Copy_Node (Source => New_Node, Destination => Old_Node); - Nodes.Table (Old_Node).Error_Posted := Old_Error_P; + Nodes.Table (Old_Node).Error_Posted := Old_Error_Posted; Nodes.Table (Old_Node).Has_Aspects := Old_Has_Aspects; + Flags.Table (Old_Node).Check_Actuals := Old_CA; + Flags.Table (Old_Node).Is_Ignored_Ghost_Node := Old_Is_IGN; + if Nkind (New_Node) in N_Subexpr then Set_Paren_Count (Old_Node, Old_Paren_Count); Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze); @@ -2369,6 +2402,18 @@ package body Atree is Nodes.Table (N).Has_Aspects := Val; end Set_Has_Aspects; + -------------------------------------- + -- Set_Ignored_Ghost_Recording_Proc -- + -------------------------------------- + + procedure Set_Ignored_Ghost_Recording_Proc + (Proc : Ignored_Ghost_Record_Proc) + is + begin + pragma Assert (Ignored_Ghost_Recording_Proc = null); + Ignored_Ghost_Recording_Proc := Proc; + end Set_Ignored_Ghost_Recording_Proc; + ------------------------------- -- Set_Is_Ignored_Ghost_Node -- ------------------------------- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 24d4918..b0a0334 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -570,6 +570,13 @@ package Atree is -- are appropriately updated. This function is used only by Sinfo.CN to -- change nodes into their corresponding entities. + type Ignored_Ghost_Record_Proc is access procedure (N : Node_Or_Entity_Id); + + procedure Set_Ignored_Ghost_Recording_Proc + (Proc : Ignored_Ghost_Record_Proc); + -- Register a procedure that is invoked when an ignored Ghost node or + -- entity is created. + type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id); procedure Set_Reporting_Proc (Proc : Report_Proc); diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 3950dc7..4b4e2bb 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -745,10 +745,14 @@ package body Bindgen is WBI (" Default_Stack_Size : Integer;"); WBI (" pragma Import (C, Default_Stack_Size, " & """__gl_default_stack_size"");"); - WBI (" Default_Secondary_Stack_Size : " & - "System.Parameters.Size_Type;"); - WBI (" pragma Import (C, Default_Secondary_Stack_Size, " & - """__gnat_default_ss_size"");"); + + if Sec_Stack_Used then + WBI (" Default_Secondary_Stack_Size : " & + "System.Parameters.Size_Type;"); + WBI (" pragma Import (C, Default_Secondary_Stack_Size, " & + """__gnat_default_ss_size"");"); + end if; + WBI (" Leap_Seconds_Support : Integer;"); WBI (" pragma Import (C, Leap_Seconds_Support, " & """__gl_leap_seconds_support"");"); diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 8e061eb..871f1f7 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1873,29 +1873,36 @@ package body Checks is pragma Assert (Do_Division_Check (N)); Loc : constant Source_Ptr := Sloc (N); - Right : constant Node_Id := Right_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Opnd : Node_Id; begin if Expander_Active and then not Backend_Divide_Checks_On_Target and then Check_Needed (Right, Division_Check) - then - -- See if division by zero possible, and if so generate test. This - -- part of the test is not controlled by the -gnato switch, since - -- it is a Division_Check and not an Overflow_Check. - if Do_Division_Check (N) then - Set_Do_Division_Check (N, False); + -- See if division by zero possible, and if so generate test. This + -- part of the test is not controlled by the -gnato switch, since it + -- is a Division_Check and not an Overflow_Check. - if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => Duplicate_Subexpr_Move_Checks (Right), - Right_Opnd => Make_Integer_Literal (Loc, 0)), - Reason => CE_Divide_By_Zero)); + and then Do_Division_Check (N) + then + Set_Do_Division_Check (N, False); + + if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then + if Is_Floating_Point_Type (Etype (N)) then + Opnd := Make_Real_Literal (Loc, Ureal_0); + else + Opnd := Make_Integer_Literal (Loc, 0); end if; + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Duplicate_Subexpr_Move_Checks (Right), + Right_Opnd => Opnd), + Reason => CE_Divide_By_Zero)); end if; end if; end Apply_Division_Check; @@ -3541,6 +3548,7 @@ package body Checks is and then not GNATprove_Mode then Apply_Float_Conversion_Check (Expr, Target_Type); + else Apply_Scalar_Range_Check (Expr, Target_Type, Fixed_Int => Conv_OK); diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 736742d..387083c 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -694,6 +694,7 @@ package body Clean is Arg : constant String := Argument (Index); procedure Bad_Argument; + pragma No_Return (Bad_Argument); -- Signal bad argument ------------------ diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 51cde06..5577604 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -53,6 +53,13 @@ with Tbuild; use Tbuild; package body Contracts is + procedure Analyze_Package_Instantiation_Contract (Inst_Id : Entity_Id); + -- Analyze all delayed pragmas chained on the contract of package + -- instantiation Inst_Id as if they appear at the end of a declarative + -- region. The pragmas in question are: + -- + -- Part_Of + procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id); -- (CodePeer): Subsidiary procedure to Analyze_Contracts which builds the -- contract-only subprogram body of eligible subprograms found in L, adds @@ -386,6 +393,11 @@ package body Contracts is elsif Nkind (Decl) = N_Object_Declaration then Analyze_Object_Contract (Defining_Entity (Decl)); + -- Package instantiation + + elsif Nkind (Decl) = N_Package_Instantiation then + Analyze_Package_Instantiation_Contract (Defining_Entity (Decl)); + -- Protected units elsif Nkind_In (Decl, N_Protected_Type_Declaration, @@ -876,8 +888,8 @@ package body Contracts is if not Is_Library_Level_Entity (Obj_Id) then Error_Msg_N - ("volatile variable & must be declared at library level", - Obj_Id); + ("volatile variable & must be declared at library level " + & "(SPARK RM 7.1.3(3))", Obj_Id); -- An object of a discriminated type cannot be effectively -- volatile except for protected objects (SPARK RM 7.1.3(5)). @@ -1074,17 +1086,6 @@ package body Contracts is end if; end if; - -- Check whether the lack of indicator Part_Of agrees with the placement - -- of the package instantiation with respect to the state space. - - if Is_Generic_Instance (Pack_Id) then - Prag := Get_Pragma (Pack_Id, Pragma_Part_Of); - - if No (Prag) then - Check_Missing_Part_Of (Pack_Id); - end if; - end if; - -- Restore the SPARK_Mode of the enclosing context after all delayed -- pragmas have been analyzed. @@ -1100,6 +1101,62 @@ package body Contracts is end if; end Analyze_Package_Contract; + -------------------------------------------- + -- Analyze_Package_Instantiation_Contract -- + -------------------------------------------- + + -- WARNING: This routine manages SPARK regions. Return statements must be + -- replaced by gotos which jump to the end of the routine and restore the + -- SPARK mode. + + procedure Analyze_Package_Instantiation_Contract (Inst_Id : Entity_Id) is + Inst_Spec : constant Node_Id := + Instance_Spec (Unit_Declaration_Node (Inst_Id)); + + Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; + Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; + -- Save the SPARK_Mode-related data to restore on exit + + Pack_Id : Entity_Id; + Prag : Node_Id; + + begin + -- Nothing to do when the package instantiation is erroneous or left + -- partially decorated. + + if No (Inst_Spec) then + return; + end if; + + Pack_Id := Defining_Entity (Inst_Spec); + Prag := Get_Pragma (Pack_Id, Pragma_Part_Of); + + -- Due to the timing of contract analysis, delayed pragmas may be + -- subject to the wrong SPARK_Mode, usually that of the enclosing + -- context. To remedy this, restore the original SPARK_Mode of the + -- related package. + + Set_SPARK_Mode (Pack_Id); + + -- Check whether the lack of indicator Part_Of agrees with the placement + -- of the package instantiation with respect to the state space. Nested + -- package instantiations do not need to be checked because they inherit + -- Part_Of indicator of the outermost package instantiation (see routine + -- Propagate_Part_Of in Sem_Prag). + + if In_Instance then + null; + + elsif No (Prag) then + Check_Missing_Part_Of (Pack_Id); + end if; + + -- Restore the SPARK_Mode of the enclosing context after all delayed + -- pragmas have been analyzed. + + Restore_SPARK_Mode (Saved_SM, Saved_SMP); + end Analyze_Package_Instantiation_Contract; + -------------------------------- -- Analyze_Protected_Contract -- -------------------------------- @@ -2284,7 +2341,9 @@ package body Contracts is if Present (Items) then Prag := Contract_Test_Cases (Items); while Present (Prag) loop - if Pragma_Name (Prag) = Name_Contract_Cases then + if Pragma_Name (Prag) = Name_Contract_Cases + and then Is_Checked (Prag) + then Expand_Pragma_Contract_Cases (CCs => Prag, Subp_Id => Subp_Id, @@ -2342,7 +2401,9 @@ package body Contracts is if Present (Items) then Prag := Pre_Post_Conditions (Items); while Present (Prag) loop - if Pragma_Name (Prag) = Post_Nam then + if Pragma_Name (Prag) = Post_Nam + and then Is_Checked (Prag) + then Append_Enabled_Item (Item => Build_Pragma_Check_Equivalent (Prag), List => Stmts); @@ -2364,7 +2425,9 @@ package body Contracts is -- Note that non-matching pragmas are skipped if Nkind (Decl) = N_Pragma then - if Pragma_Name (Decl) = Post_Nam then + if Pragma_Name (Decl) = Post_Nam + and then Is_Checked (Decl) + then Append_Enabled_Item (Item => Build_Pragma_Check_Equivalent (Decl), List => Stmts); @@ -2394,6 +2457,7 @@ package body Contracts is procedure Process_Spec_Postconditions is Subps : constant Subprogram_List := Inherited_Subprograms (Spec_Id); + Item : Node_Id; Items : Node_Id; Prag : Node_Id; Subp_Id : Entity_Id; @@ -2406,7 +2470,9 @@ package body Contracts is if Present (Items) then Prag := Pre_Post_Conditions (Items); while Present (Prag) loop - if Pragma_Name (Prag) = Name_Postcondition then + if Pragma_Name (Prag) = Name_Postcondition + and then Is_Checked (Prag) + then Append_Enabled_Item (Item => Build_Pragma_Check_Equivalent (Prag), List => Stmts); @@ -2429,13 +2495,20 @@ package body Contracts is if Pragma_Name (Prag) = Name_Postcondition and then Class_Present (Prag) then - Append_Enabled_Item - (Item => - Build_Pragma_Check_Equivalent - (Prag => Prag, - Subp_Id => Spec_Id, - Inher_Id => Subp_Id), - List => Stmts); + Item := + Build_Pragma_Check_Equivalent + (Prag => Prag, + Subp_Id => Spec_Id, + Inher_Id => Subp_Id); + + -- The pragma Check equivalent of the class-wide + -- postcondition is still created even though the + -- pragma may be ignored because the equivalent + -- performs semantic checks. + + if Is_Checked (Prag) then + Append_Enabled_Item (Item, Stmts); + end if; end if; Prag := Next_Pragma (Prag); @@ -2630,9 +2703,11 @@ package body Contracts is ---------------------- procedure Prepend_To_Decls (Item : Node_Id) is - Decls : List_Id := Declarations (Body_Decl); + Decls : List_Id; begin + Decls := Declarations (Body_Decl); + -- Ensure that the body has a declarative list if No (Decls) then @@ -2680,12 +2755,13 @@ package body Contracts is ------------------------------------- procedure Process_Inherited_Preconditions is - Subps : constant Subprogram_List := - Inherited_Subprograms (Spec_Id); - Check_Prag : Node_Id; - Items : Node_Id; - Prag : Node_Id; - Subp_Id : Entity_Id; + Subps : constant Subprogram_List := + Inherited_Subprograms (Spec_Id); + + Item : Node_Id; + Items : Node_Id; + Prag : Node_Id; + Subp_Id : Entity_Id; begin -- Process the contracts of all inherited subprograms, looking for @@ -2701,20 +2777,29 @@ package body Contracts is if Pragma_Name (Prag) = Name_Precondition and then Class_Present (Prag) then - Check_Prag := + Item := Build_Pragma_Check_Equivalent (Prag => Prag, Subp_Id => Spec_Id, Inher_Id => Subp_Id); - -- The spec of an inherited subprogram already yielded - -- a class-wide precondition. Merge the existing - -- precondition with the current one using "or else". + -- The pragma Check equivalent of the class-wide + -- precondition is still created even though the + -- pragma may be ignored because the equivalent + -- performs semantic checks. + + if Is_Checked (Prag) then - if Present (Class_Pre) then - Merge_Preconditions (Check_Prag, Class_Pre); - else - Class_Pre := Check_Prag; + -- The spec of an inherited subprogram already + -- yielded a class-wide precondition. Merge the + -- existing precondition with the current one + -- using "or else". + + if Present (Class_Pre) then + Merge_Preconditions (Item, Class_Pre); + else + Class_Pre := Item; + end if; end if; end if; @@ -2736,7 +2821,8 @@ package body Contracts is ------------------------------- procedure Process_Preconditions_For (Subp_Id : Entity_Id) is - Items : constant Node_Id := Contract (Subp_Id); + Items : constant Node_Id := Contract (Subp_Id); + Decl : Node_Id; Prag : Node_Id; Subp_Decl : Node_Id; @@ -2747,7 +2833,9 @@ package body Contracts is if Present (Items) then Prag := Pre_Post_Conditions (Items); while Present (Prag) loop - if Pragma_Name (Prag) = Name_Precondition then + if Pragma_Name (Prag) = Name_Precondition + and then Is_Checked (Prag) + then Prepend_To_Decls_Or_Save (Prag); end if; @@ -2772,7 +2860,9 @@ package body Contracts is -- Note that non-matching pragmas are skipped if Nkind (Decl) = N_Pragma then - if Pragma_Name (Decl) = Name_Precondition then + if Pragma_Name (Decl) = Name_Precondition + and then Is_Checked (Decl) + then Prepend_To_Decls_Or_Save (Decl); end if; @@ -2908,20 +2998,18 @@ package body Contracts is elsif Is_Ignored_Ghost_Entity (Subp_Id) then return; - end if; -- Do not re-expand the same contract. This scenario occurs when a -- construct is rewritten into something else during its analysis -- (expression functions for instance). - if Has_Expanded_Contract (Subp_Id) then + elsif Has_Expanded_Contract (Subp_Id) then return; + end if; - -- Otherwise mark the subprogram + -- Prevent multiple expansion attempts of the same contract - else - Set_Has_Expanded_Contract (Subp_Id); - end if; + Set_Has_Expanded_Contract (Subp_Id); -- Ensure that the formal parameters are visible when expanding all -- contract items. diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads index 4a0997f..46f52d1 100644 --- a/gcc/ada/contracts.ads +++ b/gcc/ada/contracts.ads @@ -35,6 +35,7 @@ package Contracts is -- [generic] package, package body, protected unit, [generic] subprogram, -- subprogram body, variable or task unit denoted by Id. The following are -- valid pragmas: + -- -- Abstract_State -- Async_Readers -- Async_Writers @@ -66,6 +67,7 @@ package Contracts is -- Analyze all delayed pragmas chained on the contract of entry or -- subprogram body Body_Id as if they appeared at the end of a declarative -- region. Pragmas in question are: + -- -- Contract_Cases (stand alone subprogram body) -- Depends (stand alone subprogram body) -- Global (stand alone subprogram body) @@ -82,6 +84,7 @@ package Contracts is -- Analyze all delayed pragmas chained on the contract of entry or -- subprogram Subp_Id as if they appeared at the end of a declarative -- region. The pragmas in question are: + -- -- Contract_Cases -- Depends -- Global @@ -98,6 +101,7 @@ package Contracts is -- Analyze all delayed pragmas chained on the contract of object Obj_Id as -- if they appeared at the end of the declarative region. The pragmas to be -- considered are: + -- -- Async_Readers -- Async_Writers -- Depends (single concurrent object) @@ -115,6 +119,7 @@ package Contracts is -- Analyze all delayed pragmas chained on the contract of package body -- Body_Id as if they appeared at the end of a declarative region. The -- pragmas that are considered are: + -- -- Refined_State -- -- Freeze_Id is the entity of a [generic] package body or a [generic] @@ -124,9 +129,9 @@ package Contracts is -- Analyze all delayed pragmas chained on the contract of package Pack_Id -- as if they appeared at the end of a declarative region. The pragmas -- that are considered are: + -- -- Initial_Condition -- Initializes - -- Part_Of procedure Analyze_Protected_Contract (Prot_Id : Entity_Id); -- Analyze all delayed pragmas chained on the contract of protected unit @@ -137,6 +142,7 @@ package Contracts is -- Analyze all delayed pragmas chained on the contract of subprogram body -- stub Stub_Id as if they appeared at the end of a declarative region. The -- pragmas in question are: + -- -- Contract_Cases -- Depends -- Global @@ -151,6 +157,7 @@ package Contracts is -- Analyze all delayed pragmas chained on the contract of task unit Task_Id -- as if they appeared at the end of a declarative region. The pragmas in -- question are: + -- -- Depends -- Global diff --git a/gcc/ada/doc/gnat_rm.rst b/gcc/ada/doc/gnat_rm.rst index 9360a8f..97f7e4d 100644 --- a/gcc/ada/doc/gnat_rm.rst +++ b/gcc/ada/doc/gnat_rm.rst @@ -14,7 +14,7 @@ GNAT Reference Manual .. only:: GPL - *GNAT GPL Edition* + *GNAT Community Edition* | Version |version| | Date: |today| diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index aec0d84..44afec4 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -396,7 +396,7 @@ Pragma Assertion_Policy Syntax:: - pragma Assertion_Policy (CHECK | DISABLE | IGNORE); + pragma Assertion_Policy (CHECK | DISABLE | IGNORE | SUPPRESSIBLE); pragma Assertion_Policy ( ASSERTION_KIND => POLICY_IDENTIFIER diff --git a/gcc/ada/doc/gnat_ugn.rst b/gcc/ada/doc/gnat_ugn.rst index b6fd18f..0ac6876 100644 --- a/gcc/ada/doc/gnat_ugn.rst +++ b/gcc/ada/doc/gnat_ugn.rst @@ -14,7 +14,7 @@ GNAT User's Guide for Native Platforms .. only:: GPL - *GNAT GPL Edition* + *GNAT Community Edition* | Version |version| | Date: |today| diff --git a/gcc/ada/doc/gnat_ugn/about_this_guide.rst b/gcc/ada/doc/gnat_ugn/about_this_guide.rst index e303721..d322b9d 100644 --- a/gcc/ada/doc/gnat_ugn/about_this_guide.rst +++ b/gcc/ada/doc/gnat_ugn/about_this_guide.rst @@ -160,7 +160,7 @@ the new document structure. * :ref:`GNAT_and_Program_Execution` is a new chapter consolidating the following: - :ref:`Running_and_Debugging_Ada_Programs` - - :ref:`Code_Coverage_and_Profiling` + - :ref:`Profiling` - :ref:`Improving_Performance` - :ref:`Overflow Check Handling in GNAT <Overflow_Check_Handling_in_GNAT>` - :ref:`Performing Dimensionality Analysis in GNAT <Performing_Dimensionality_Analysis_in_GNAT>` 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 97ae764..e79f630 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 @@ -720,9 +720,9 @@ is passed to ``gcc`` (e.g., :switch:`-O`, :switch:`-gnato,` etc.) .. index:: --RTS (gnatmake) :switch:`--RTS={rts-path}` - Specifies the default location of the runtime library. GNAT looks for the - runtime - in the following directories, and stops as soon as a valid runtime is found + Specifies the default location of the run-time library. GNAT looks for the + run-time + in the following directories, and stops as soon as a valid run-time is found (:file:`adainclude` or :file:`ada_source_path`, and :file:`adalib` or :file:`ada_object_path` present): @@ -1505,7 +1505,7 @@ Alphabetical List of All Switches In the example above, the first call to ``Detect_Aliasing`` fails with a - ``Program_Error`` at runtime because the actuals for ``Val_1`` and + ``Program_Error`` at run time because the actuals for ``Val_1`` and ``Val_2`` denote the same object. The second call executes without raising an exception because ``Self(Obj)`` produces an anonymous object which does not share the memory location of ``Obj``. @@ -1817,14 +1817,12 @@ Alphabetical List of All Switches .. index:: -gnatg (gcc) :switch:`-gnatg` - Internal GNAT implementation mode. This should not be used for - applications programs, it is intended only for use by the compiler - and its run-time library. For documentation, see the GNAT sources. - Note that :switch:`-gnatg` implies - :switch:`-gnatw.ge` and - :switch:`-gnatyg` - so that all standard warnings and all standard style options are turned on. - All warnings and style messages are treated as errors. + Internal GNAT implementation mode. This should not be used for applications + programs, it is intended only for use by the compiler and its run-time + library. For documentation, see the GNAT sources. Note that :switch:`-gnatg` + implies :switch:`-gnatw.ge` and :switch:`-gnatyg` so that all standard + warnings and all standard style options are turned on. All warnings and style + messages are treated as errors. .. index:: -gnatG[nn] (gcc) @@ -1839,6 +1837,13 @@ Alphabetical List of All Switches Output usage information. The output is written to :file:`stdout`. +.. index:: -gnatH (gcc) + +:switch:`-gnatH` + Legacy elaboration-checking mode enabled. When this switch is in effect, the + pre-18.x access-before-elaboration model becomes the de facto model. + + .. index:: -gnati (gcc) :switch:`-gnati{c}` @@ -1874,6 +1879,27 @@ Alphabetical List of All Switches Reformat error messages to fit on ``nn`` character lines +.. index:: -gnatJ (gcc) + +:switch:`-gnatJ` + Permissive elaboration-checking mode enabled. When this switch is in effect, + the post-18.x access-before-elaboration model ignores potential issues with: + + - Accept statements + - Activations of tasks defined in instances + - Assertion pragmas + - Calls from within an instance to its enclosing context + - Calls through generic formal parameters + - Calls to subprograms defined in instances + - Entry calls + - Indirect calls using 'Access + - Requeue statements + - Select statements + - Synchronous task suspension + + and does not emit compile-time diagnostics or run-time checks. + + .. index:: -gnatk (gcc) :switch:`-gnatk={n}` @@ -2195,7 +2221,7 @@ Alphabetical List of All Switches .. index:: --RTS (gcc) :switch:`--RTS={rts-path}` - Specifies the default location of the runtime library. Same meaning as the + Specifies the default location of the run-time library. Same meaning as the equivalent ``gnatmake`` flag (:ref:`Switches_for_gnatmake`). @@ -5062,7 +5088,7 @@ switches refine this default behavior. that a certain check will necessarily fail, it will generate code to do an unconditional 'raise', even if checks are suppressed. The compiler warns in this case. Another case in which checks may not be - eliminated is when they are embedded in certain run time routines such + eliminated is when they are embedded in certain run-time routines such as math library routines. Of course, run-time checks are omitted whenever the compiler can prove @@ -5858,7 +5884,7 @@ Debugging Control Exception Handling Control -------------------------- -GNAT uses two methods for handling exceptions at run-time. The +GNAT uses two methods for handling exceptions at run time. The ``setjmp/longjmp`` method saves the context when entering a frame with an exception handler. Then when an exception is raised, the context can be restored immediately, without the @@ -6367,7 +6393,7 @@ be presented in subsequent sections. .. index:: --RTS (gnatbind) :switch:`--RTS={rts-path}` - Specifies the default location of the runtime library. Same meaning as the + Specifies the default location of the run-time library. Same meaning as the equivalent ``gnatmake`` flag (:ref:`Switches_for_gnatmake`). .. index:: -o (gnatbind) @@ -6470,13 +6496,13 @@ be presented in subsequent sections. .. index:: -static (gnatbind) :switch:`-static` - Link against a static GNAT run time. + Link against a static GNAT run-time. .. index:: -shared (gnatbind) :switch:`-shared` - Link against a shared GNAT run time when available. + Link against a shared GNAT run-time when available. .. index:: -t (gnatbind) @@ -6495,7 +6521,7 @@ be presented in subsequent sections. nonzero value will activate round-robin scheduling. A value of zero is treated specially. It turns off time - slicing, and in addition, indicates to the tasking run time that the + slicing, and in addition, indicates to the tasking run-time that the semantics should match as closely as possible the Annex D requirements of the Ada RM, and in particular sets the default scheduling policy to ``FIFO_Within_Priorities``. @@ -6939,7 +6965,7 @@ The output is an Ada unit in source form that can be compiled with GNAT. This compilation occurs automatically as part of the ``gnatlink`` processing. -Currently the GNAT run time requires a FPU using 80 bits mode +Currently the GNAT run-time requires a FPU using 80 bits mode precision. Under targets where this is not the default it is required to call GNAT.Float_Control.Reset before using floating point numbers (this include float computation, float input and output) in the Ada code. A @@ -7040,7 +7066,7 @@ directories searched are: * The content of the :file:`ada_object_path` file which is part of the GNAT installation tree and is used to store standard libraries such as the - GNAT Run Time Library (RTL) unless the switch :switch:`-nostdlib` is + GNAT Run-Time Library (RTL) unless the switch :switch:`-nostdlib` is specified. See :ref:`Installing_a_library` .. index:: -I (gnatbind) diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index da8a080..3e0c6ff 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -17,7 +17,7 @@ GNAT and Program Execution This chapter covers several topics: * `Running and Debugging Ada Programs`_ -* `Code Coverage and Profiling`_ +* `Profiling`_ * `Improving Performance`_ * `Overflow Check Handling in GNAT`_ * `Performing Dimensionality Analysis in GNAT`_ @@ -1206,103 +1206,16 @@ documentation for more information. -.. index:: Code Coverage .. index:: Profiling -.. _Code_Coverage_and_Profiling: +.. _Profiling: -Code Coverage and Profiling -=========================== - -This section describes how to use the ``gcov`` coverage testing tool and -the ``gprof`` profiler tool on Ada programs. - -.. index:: ! gcov - -.. _Code_Coverage_of_Ada_Programs_with_gcov: - -Code Coverage of Ada Programs with gcov ---------------------------------------- - -``gcov`` is a test coverage program: it analyzes the execution of a given -program on selected tests, to help you determine the portions of the program -that are still untested. - -``gcov`` is part of the GCC suite, and is described in detail in the GCC -User's Guide. You can refer to this documentation for a more complete -description. - -This chapter provides a quick startup guide, and -details some GNAT-specific features. - -.. _Quick_startup_guide: - -Quick startup guide -^^^^^^^^^^^^^^^^^^^ - -In order to perform coverage analysis of a program using ``gcov``, several -steps are needed: - -#. Instrument the code during the compilation process, -#. Execute the instrumented program, and -#. Invoke the ``gcov`` tool to generate the coverage results. - -.. index:: -fprofile-arcs (gcc) -.. index:: -ftest-coverage (gcc -.. index:: -fprofile-arcs (gnatbind) - -The code instrumentation needed by gcov is created at the object level. -The source code is not modified in any way, because the instrumentation code is -inserted by gcc during the compilation process. To compile your code with code -coverage activated, you need to recompile your whole project using the -switches -:switch:`-fprofile-arcs` and :switch:`-ftest-coverage`, and link it using -:switch:`-fprofile-arcs`. - - :: - - $ gnatmake -P my_project.gpr -f -cargs -fprofile-arcs -ftest-coverage \\ - -largs -fprofile-arcs - -This compilation process will create :file:`.gcno` files together with -the usual object files. - -Once the program is compiled with coverage instrumentation, you can -run it as many times as needed -- on portions of a test suite for -example. The first execution will produce :file:`.gcda` files at the -same location as the :file:`.gcno` files. Subsequent executions -will update those files, so that a cumulative result of the covered -portions of the program is generated. - -Finally, you need to call the ``gcov`` tool. The different options of -``gcov`` are described in the GCC User's Guide, section *Invoking gcov*. - -This will create annotated source files with a :file:`.gcov` extension: -:file:`my_main.adb` file will be analyzed in :file:`my_main.adb.gcov`. - - -.. _GNAT_specifics: - -GNAT specifics -^^^^^^^^^^^^^^ - -Because of Ada semantics, portions of the source code may be shared among -several object files. This is the case for example when generics are -involved, when inlining is active or when declarations generate initialisation -calls. In order to take -into account this shared code, you need to call ``gcov`` on all -source files of the tested program at once. - -The list of source files might exceed the system's maximum command line -length. In order to bypass this limitation, a new mechanism has been -implemented in ``gcov``: you can now list all your project's files into a -text file, and provide this file to gcov as a parameter, preceded by a ``@`` -(e.g. :samp:`gcov @mysrclist.txt`). - -Note that on AIX compiling a static library with :switch:`-fprofile-arcs` is -not supported as there can be unresolved symbols during the final link. +Profiling +========= +This section describes how to use the the ``gprof`` profiler tool on Ada +programs. .. index:: ! gprof .. index:: Profiling @@ -1324,7 +1237,6 @@ better handle Ada programs and multitasking. It is currently supported on the following platforms * linux x86/x86_64 -* solaris sparc/sparc64/x86 * windows x86 In order to profile a program using ``gprof``, several steps are needed: diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index c41dc30..e89ea5a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -5972,7 +5972,7 @@ package body Einfo is procedure Set_Is_Uplevel_Referenced_Entity (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Constant, E_Variable, E_Discriminant) + (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable) or else Is_Formal (Id) or else Is_Type (Id)); Set_Flag283 (Id, V); @@ -8385,7 +8385,7 @@ package body Einfo is function Is_Wrapper_Package (Id : E) return B is begin - return (Ekind (Id) = E_Package and then Present (Related_Instance (Id))); + return Ekind (Id) = E_Package and then Present (Related_Instance (Id)); end Is_Wrapper_Package; ----------------- @@ -9815,6 +9815,7 @@ package body Einfo is W ("Is_Abstract_Subprogram", Flag19 (Id)); W ("Is_Abstract_Type", Flag146 (Id)); W ("Is_Access_Constant", Flag69 (Id)); + W ("Is_Activation_Record", Flag305 (Id)); W ("Is_Actual_Subtype", Flag293 (Id)); W ("Is_Ada_2005_Only", Flag185 (Id)); W ("Is_Ada_2012_Only", Flag199 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 79fd1c2..8e5bf65 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1034,7 +1034,7 @@ package Einfo is -- base type). -- -- In all other cases Discriminant_Constraint contains the empty --- Elist (ie it is initialized with a call to New_Elmt_List). +-- Elist (i.e. it is initialized with a call to New_Elmt_List). -- Discriminant_Default_Value (Node20) -- Defined in discriminants. Points to the node representing the @@ -3139,8 +3139,8 @@ package Einfo is -- flag may be set for any other functions or procedures that are known -- to be side effect free, so in the case of subprograms, the Is_Pure -- flag may be used by the optimizer to imply that it can assume freedom --- from side effects (other than those resulting from assignment to out --- parameters, or to objects designated by access parameters). +-- from side effects (other than those resulting from assignment to Out +-- or In Out parameters, or to objects designated by access parameters). -- Is_Pure_Unit_Access_Type (Flag189) -- Defined in access type and subtype entities. Set if the type or @@ -4222,8 +4222,9 @@ package Einfo is -- could be obtained by rummaging around the tree, but it is more -- convenient to have it immediately at hand in the entity. The -- contents of Scalar_Range can either be an N_Subtype_Indication --- node (with a constraint), or a Range node, but not a simple --- subtype reference (a subtype is converted into a range). +-- node (with a constraint), a Range node, or an Integer_Type_Definition, +-- but not a simple subtype reference (a subtype is converted into a +-- explicit range). -- Scale_Value (Uint16) -- Defined in decimal fixed-point types and subtypes. Contains the scale diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 587dcfe..17a86f0 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -3257,37 +3257,6 @@ package body Errout is if Debug_Flag_OO then return False; - -- Processing for "atomic access cannot be guaranteed" - - elsif Msg = "atomic access to & cannot be guaranteed" then - - -- When an atomic object refers to a non-atomic type in the same - -- scope, we implicitly make the type atomic. In the non-error case - -- this is surely safe (and in fact prevents an error from occurring - -- if the type is not atomic by default). But if the object cannot be - -- made atomic, then we introduce an extra junk message by this - -- manipulation, which we get rid of here. - - -- We identify this case by the fact that it references a type for - -- which Is_Atomic is set, but there is no Atomic pragma setting it. - - if Is_Type (E) - and then Is_Atomic (E) - and then No (Get_Rep_Pragma (E, Name_Atomic)) - then - return True; - end if; - - -- Similar processing for "volatile full access cannot be guaranteed" - - elsif Msg = "volatile full access to & cannot be guaranteed" then - if Is_Type (E) - and then Is_Volatile_Full_Access (E) - and then No (Get_Rep_Pragma (E, Name_Volatile_Full_Access)) - then - return True; - end if; - -- Processing for "Size too small" messages elsif Msg = "size for& too small, minimum allowed is ^" then diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index b8955d7..9d9ab6a 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -7238,6 +7238,32 @@ package body Exp_Aggr is Expr_Q := Expression (C); end if; + -- Return False for array components whose bounds raise + -- constraint error. + + declare + Comp : constant Entity_Id := First (Choices (C)); + Indx : Node_Id; + + begin + if Present (Etype (Comp)) + and then Is_Array_Type (Etype (Comp)) + then + Indx := First_Index (Etype (Comp)); + while Present (Indx) loop + if Nkind (Type_Low_Bound (Etype (Indx))) = + N_Raise_Constraint_Error + or else Nkind (Type_High_Bound (Etype (Indx))) = + N_Raise_Constraint_Error + then + return False; + end if; + + Indx := Next_Index (Indx); + end loop; + end if; + end; + -- Return False if the aggregate has any associations for tagged -- components that may require tag adjustment. @@ -7248,10 +7274,11 @@ package body Exp_Aggr is -- the machine.) if Is_Tagged_Type (Etype (Expr_Q)) - and then (Nkind (Expr_Q) = N_Type_Conversion - or else (Is_Entity_Name (Expr_Q) - and then - Ekind (Entity (Expr_Q)) in Formal_Kind)) + and then + (Nkind (Expr_Q) = N_Type_Conversion + or else + (Is_Entity_Name (Expr_Q) + and then Is_Formal (Entity (Expr_Q)))) and then Tagged_Type_Expansion then Static_Components := False; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 30d6605..469a90e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -724,13 +724,44 @@ package body Exp_Attr is Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V'); Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); - Rec_Decl : constant Node_Id := Declaration_Node (Rec_Typ); - Rec_Def : constant Node_Id := Type_Definition (Rec_Decl); + Comps : Node_Id; Stmts : List_Id; + Typ : Entity_Id; + Typ_Decl : Node_Id; + Typ_Def : Node_Id; + Typ_Ext : Node_Id; -- Start of processing for Build_Record_VS_Func begin + Typ := Rec_Typ; + + -- Use the root type when dealing with a class-wide type + + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + Typ_Decl := Declaration_Node (Typ); + Typ_Def := Type_Definition (Typ_Decl); + + -- The components of a derived type are located in the extension part + + if Nkind (Typ_Def) = N_Derived_Type_Definition then + Typ_Ext := Record_Extension_Part (Typ_Def); + + if Present (Typ_Ext) then + Comps := Component_List (Typ_Ext); + else + Comps := Empty; + end if; + + -- Otherwise the components are available in the definition + + else + Comps := Component_List (Typ_Def); + end if; + -- The code generated by this routine is as follows: -- -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is @@ -774,7 +805,7 @@ package body Exp_Attr is if not Is_Unchecked_Union (Rec_Typ) then Validate_Fields (Obj_Id => Obj_Id, - Fields => Discriminant_Specifications (Rec_Decl), + Fields => Discriminant_Specifications (Typ_Decl), Stmts => Stmts); end if; @@ -782,7 +813,7 @@ package body Exp_Attr is Validate_Component_List (Obj_Id => Obj_Id, - Comp_List => Component_List (Rec_Def), + Comp_List => Comps, Stmts => Stmts); -- Generate: @@ -3049,6 +3080,16 @@ package body Exp_Attr is -- Protected case if Is_Protected_Type (Conctyp) then + + -- No need to transform 'Count into a function call if the current + -- scope has been eliminated. In this case such transformation is + -- also not viable because the enclosing protected object is not + -- available. + + if Is_Eliminated (Current_Scope) then + return; + end if; + case Corresponding_Runtime_Package (Conctyp) is when System_Tasking_Protected_Objects_Entries => Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc); @@ -3598,6 +3639,10 @@ package body Exp_Attr is -- not want this to go through the fixed-point conversion circuits. Note -- that the back end always treats fixed-point as equivalent to the -- corresponding integer type anyway. + -- However, in order to remove the handling of Do_Range_Check from the + -- backend, we force the generation of a check on the result by + -- setting the result type appropriately. Apply_Conversion_Checks + -- will generate the required expansion. when Attribute_Fixed_Value | Attribute_Integer_Value @@ -3606,15 +3651,53 @@ package body Exp_Attr is Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), Expression => Relocate_Node (First (Exprs)))); - Set_Etype (N, Entity (Pref)); + + -- Indicate that the result of the conversion may require a + -- range check (see below); + + Set_Etype (N, Base_Type (Entity (Pref))); Set_Analyzed (N); -- Note: it might appear that a properly analyzed unchecked -- conversion would be just fine here, but that's not the case, - -- since the full range checks performed by the following call + -- since the full range checks performed by the following code -- are critical. + -- Given that Fixed-point conversions are not further expanded + -- to prevent the involvement of real type operations we have to + -- construct two checks explicitly: one on the operand, and one + -- on the result. This used to be done in part in the back-end, + -- but for other targets (E.g. LLVM) it is preferable to create + -- the tests in full in the front-end. + + if Is_Fixed_Point_Type (Etype (N)) then + declare + Loc : constant Source_Ptr := Sloc (N); + Equiv_T : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Expr : constant Node_Id := Expression (N); + Fst : constant Entity_Id := Root_Type (Etype (N)); + Decl : Node_Id; + + begin + Decl := Make_Full_Type_Declaration (Sloc (N), + Equiv_T, + Type_Definition => + Make_Signed_Integer_Type_Definition (Loc, + Low_Bound => Make_Integer_Literal (Loc, + Intval => Corresponding_Integer_Value + (Type_Low_Bound (Fst))), + High_Bound => Make_Integer_Literal (Loc, + Intval => Corresponding_Integer_Value + (Type_High_Bound (Fst))))); + Insert_Action (N, Decl); - Apply_Type_Conversion_Checks (N); + -- Verify that the conversion is possible. + Generate_Range_Check + (Expr, Equiv_T, CE_Overflow_Check_Failed); + + -- and verify that the result is in range. + Generate_Range_Check (N, Etype (N), CE_Range_Check_Failed); + end; + end if; ----------- -- Floor -- diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index b197c4e..da95b71 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -913,8 +913,8 @@ package body Exp_Ch11 is Cond := Condition (Raise_S); -- The only other possibility is a node that is or used to be a - -- simple raise statement. Note that the string expression in - -- the original Raise statement is ignored. + -- simple raise statement. Note that the string expression in the + -- original Raise statement is ignored. else Orig := Original_Node (Raise_S); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 89be351..4f95fc8 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -470,6 +470,11 @@ package body Exp_Ch13 is and then Ekind (E_Scope) not in Concurrent_Kind then E_Scope := Scope (E_Scope); + + -- The entity may be a subtype declared for an iterator + + elsif Ekind (E_Scope) = E_Loop then + E_Scope := Scope (E_Scope); end if; -- Remember that we are processing a freezing entity and its freezing diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 354d6ba..9281896 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -9220,9 +9220,9 @@ package body Exp_Ch3 is end loop; end Make_Controlling_Function_Wrappers; - ------------------- - -- Make_Eq_Body -- - ------------------- + ------------------ + -- Make_Eq_Body -- + ------------------ function Make_Eq_Body (Typ : Entity_Id; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0d836f8..b08cf37 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4072,7 +4072,7 @@ package body Exp_Ch4 is -- we avoid never-ending loops expanding them, and we also ensure -- the back end never receives nonbinary modular type expressions. - if Nkind_In (Nkind (N), N_Op_And, N_Op_Or) then + if Nkind_In (Nkind (N), N_Op_And, N_Op_Or, N_Op_Xor) then Set_Left_Opnd (Op_Expr, Unchecked_Convert_To (Standard_Unsigned, New_Copy_Tree (Left_Opnd (N)))); @@ -4561,12 +4561,14 @@ package body Exp_Ch4 is end if; end if; - -- If no storage pool has been specified and we have the restriction + -- If no storage pool has been specified, or the storage pool + -- is System.Pool_Global.Global_Pool_Object, and the restriction -- No_Standard_Allocators_After_Elaboration is present, then generate -- a call to Elaboration_Allocators.Check_Standard_Allocator. if Nkind (N) = N_Allocator - and then No (Storage_Pool (N)) + and then (No (Storage_Pool (N)) + or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object)) and then Restriction_Active (No_Standard_Allocators_After_Elaboration) then Insert_Action (N, @@ -10019,6 +10021,8 @@ package body Exp_Ch4 is elsif Is_Intrinsic_Subprogram (Entity (N)) then Expand_Intrinsic_Call (N, Entity (N)); end if; + + Expand_Nonbinary_Modular_Op (N); end Expand_N_Op_Xor; ---------------------- @@ -12154,12 +12158,11 @@ package body Exp_Ch4 is -- Generates the following code: (assuming that Typ has one Discr and -- component C2 is also a record) - -- True - -- and then Lhs.Discr1 = Rhs.Discr1 - -- and then Lhs.C1 = Rhs.C1 - -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn - -- and then ... - -- and then Lhs.Cmpn = Rhs.Cmpn + -- Lhs.Discr1 = Rhs.Discr1 + -- and then Lhs.C1 = Rhs.C1 + -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn + -- and then ... + -- and then Lhs.Cmpn = Rhs.Cmpn Result := New_Occurrence_Of (Standard_True, Loc); C := Element_To_Compare (First_Entity (Typ)); @@ -12171,7 +12174,6 @@ package body Exp_Ch4 is begin if First_Time then - First_Time := False; New_Lhs := Lhs; New_Rhs := Rhs; else @@ -12199,13 +12201,28 @@ package body Exp_Ch4 is Set_Etype (Result, Standard_Boolean); exit; else - Result := - Make_And_Then (Loc, - Left_Opnd => Result, - Right_Opnd => Check); + if First_Time then + Result := Check; + + -- Generate logical "and" for CodePeer to simplify the + -- generated code and analysis. + + elsif CodePeer_Mode then + Result := + Make_Op_And (Loc, + Left_Opnd => Result, + Right_Opnd => Check); + + else + Result := + Make_And_Then (Loc, + Left_Opnd => Result, + Right_Opnd => Check); + end if; end if; end; + First_Time := False; C := Element_To_Compare (Next_Entity (C)); end loop; @@ -12231,7 +12248,7 @@ package body Exp_Ch4 is function Make_Cond (Alt : Node_Id) return Node_Id is Cond : Node_Id; - L : constant Node_Id := New_Copy (Lop); + L : constant Node_Id := New_Copy_Tree (Lop); R : constant Node_Id := Relocate_Node (Alt); begin @@ -12530,7 +12547,7 @@ package body Exp_Ch4 is Sel_Comp := Parent (Sel_Comp); end loop; - return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind; + return Is_Formal (Entity (Prefix (Sel_Comp))); end Prefix_Is_Formal_Parameter; -- Start of processing for Has_Inferable_Discriminants diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index e0cff91..7a373ab 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1531,11 +1531,22 @@ package body Exp_Ch5 is Selector_Name => New_Occurrence_Of (Disc, Loc)); end if; + -- Generate the assignment statement. When the left-hand side + -- is an object with an address clause present, force generated + -- temporaries to be renamings so as to correctly assign to any + -- overlaid objects. + A := Make_Assignment_Statement (Loc, - Name => + Name => Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr (Lhs), + Prefix => + Duplicate_Subexpr + (Exp => Lhs, + Name_Req => False, + Renaming_Req => + Is_Entity_Name (Lhs) + and then Present (Address_Clause (Entity (Lhs)))), Selector_Name => New_Occurrence_Of (Find_Component (L_Typ, C), Loc)), Expression => Expr); @@ -3711,9 +3722,14 @@ package body Exp_Ch5 is Ind_Comp := Make_Indexed_Component (Loc, - Prefix => Relocate_Node (Array_Node), + Prefix => New_Copy_Tree (Array_Node), Expressions => New_List (New_Occurrence_Of (Iterator, Loc))); + -- Propagate the original node to the copy since the analysis of the + -- following object renaming declaration relies on the original node. + + Set_Original_Node (Prefix (Ind_Comp), Original_Node (Array_Node)); + Prepend_To (Stats, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Id, @@ -3755,7 +3771,7 @@ package body Exp_Ch5 is Defining_Identifier => Iterator, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Array_Node), + Prefix => New_Copy_Tree (Array_Node), Attribute_Name => Name_Range, Expressions => New_List ( Make_Integer_Literal (Loc, Dim1))), @@ -3792,7 +3808,7 @@ package body Exp_Ch5 is Defining_Identifier => Iterator, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Array_Node), + Prefix => New_Copy_Tree (Array_Node), Attribute_Name => Name_Range, Expressions => New_List ( Make_Integer_Literal (Loc, Dim1))), diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 2895ed9..224f4c7 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -336,22 +336,18 @@ package body Exp_Ch6 is Alloc_Form_Exp : Node_Id := Empty; Pool_Actual : Node_Id := Make_Null (No_Location)) is - Loc : constant Source_Ptr := Sloc (Function_Call); + Loc : constant Source_Ptr := Sloc (Function_Call); + Alloc_Form_Actual : Node_Id; Alloc_Form_Formal : Node_Id; Pool_Formal : Node_Id; begin - -- The allocation form generally doesn't need to be passed in the case - -- of a constrained result subtype, since normally the caller performs - -- the allocation in that case. However this formal is still needed in - -- the case where the function has a tagged result, because generally - -- such functions can be called in a dispatching context and such calls - -- must be handled like calls to class-wide functions. - - if Is_Constrained (Underlying_Type (Etype (Function_Id))) - and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id))) - then + -- Nothing to do when the size of the object is known, and the caller is + -- in charge of allocating it, and the callee doesn't unconditionally + -- require an allocation form (such as due to having a tagged result). + + if not Needs_BIP_Alloc_Form (Function_Id) then return; end if; @@ -382,8 +378,8 @@ package body Exp_Ch6 is Add_Extra_Actual_To_Call (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); - -- Pass the Storage_Pool parameter. This parameter is omitted on - -- ZFP as those targets do not support pools. + -- Pass the Storage_Pool parameter. This parameter is omitted on ZFP as + -- those targets do not support pools. if RTE_Available (RE_Root_Storage_Pool_Ptr) then Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool); @@ -4488,38 +4484,46 @@ package body Exp_Ch6 is -- That is, we need to have a reified return object if there are statements -- (which might refer to it) or if we're doing build-in-place (so we can -- set its address to the final resting place or if there is no expression - -- (in which case default initial values might need to be set). + -- (in which case default initial values might need to be set)). procedure Expand_N_Extended_Return_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - function Build_Heap_Allocator + function Build_Heap_Or_Pool_Allocator (Temp_Id : Entity_Id; Temp_Typ : Entity_Id; Func_Id : Entity_Id; Ret_Typ : Entity_Id; Alloc_Expr : Node_Id) return Node_Id; -- Create the statements necessary to allocate a return object on the - -- caller's master. The master is available through implicit parameter - -- BIPfinalizationmaster. + -- heap or user-defined storage pool. The object may need finalization + -- actions depending on the return type. -- - -- if BIPfinalizationmaster /= null then - -- declare - -- type Ptr_Typ is access Ret_Typ; - -- for Ptr_Typ'Storage_Pool use - -- Base_Pool (BIPfinalizationmaster.all).all; - -- Local : Ptr_Typ; + -- * Controlled case + -- + -- if BIPfinalizationmaster = null then + -- Temp_Id := <Alloc_Expr>; + -- else + -- declare + -- type Ptr_Typ is access Ret_Typ; + -- for Ptr_Typ'Storage_Pool use + -- Base_Pool (BIPfinalizationmaster.all).all; + -- Local : Ptr_Typ; -- - -- begin - -- procedure Allocate (...) is -- begin - -- System.Storage_Pools.Subpools.Allocate_Any (...); - -- end Allocate; + -- procedure Allocate (...) is + -- begin + -- System.Storage_Pools.Subpools.Allocate_Any (...); + -- end Allocate; -- - -- Local := <Alloc_Expr>; - -- Temp_Id := Temp_Typ (Local); - -- end; - -- end if; + -- Local := <Alloc_Expr>; + -- Temp_Id := Temp_Typ (Local); + -- end; + -- end if; + -- + -- * Non-controlled case + -- + -- Temp_Id := <Alloc_Expr>; -- -- Temp_Id is the temporary which is used to reference the internally -- created object in all allocation forms. Temp_Typ is the type of the @@ -4536,11 +4540,11 @@ package body Exp_Ch6 is -- Func_Id is the entity of the function where the extended return -- statement appears. - -------------------------- - -- Build_Heap_Allocator -- - -------------------------- + ---------------------------------- + -- Build_Heap_Or_Pool_Allocator -- + ---------------------------------- - function Build_Heap_Allocator + function Build_Heap_Or_Pool_Allocator (Temp_Id : Entity_Id; Temp_Typ : Entity_Id; Func_Id : Entity_Id; @@ -4550,7 +4554,7 @@ package body Exp_Ch6 is begin pragma Assert (Is_Build_In_Place_Function (Func_Id)); - -- Processing for build-in-place object allocation. + -- Processing for objects that require finalization actions if Needs_Finalization (Ret_Typ) then declare @@ -4558,6 +4562,10 @@ package body Exp_Ch6 is Fin_Mas_Id : constant Entity_Id := Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); + Orig_Expr : constant Node_Id := + New_Copy_Tree + (Source => Alloc_Expr, + Scopes_In_EWA_OK => True); Stmts : constant List_Id := New_List; Desig_Typ : Entity_Id; Local_Id : Entity_Id; @@ -4619,7 +4627,7 @@ package body Exp_Ch6 is -- Perform minor decoration in order to set the master and the -- storage pool attributes. - Set_Ekind (Ptr_Typ, E_Access_Type); + Set_Ekind (Ptr_Typ, E_Access_Type); Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); @@ -4658,7 +4666,9 @@ package body Exp_Ch6 is -- to a Finalize_Storage_Only allocation. -- Generate: - -- if BIPfinalizationmaster /= null then + -- if BIPfinalizationmaster = null then + -- Temp_Id := <Orig_Expr>; + -- else -- declare -- <Decls> -- begin @@ -4669,11 +4679,16 @@ package body Exp_Ch6 is return Make_If_Statement (Loc, Condition => - Make_Op_Ne (Loc, + Make_Op_Eq (Loc, Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc), Right_Opnd => Make_Null (Loc)), Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp_Id, Loc), + Expression => Orig_Expr)), + + Else_Statements => New_List ( Make_Block_Statement (Loc, Declarations => Decls, Handled_Statement_Sequence => @@ -4690,7 +4705,7 @@ package body Exp_Ch6 is Name => New_Occurrence_Of (Temp_Id, Loc), Expression => Alloc_Expr); end if; - end Build_Heap_Allocator; + end Build_Heap_Or_Pool_Allocator; --------------------------- -- Move_Activation_Chain -- @@ -4748,7 +4763,7 @@ package body Exp_Ch6 is -- the pointer to the object) they are always handled by means of -- simple return statements. - pragma Assert (not Is_Thunk (Current_Scope)); + pragma Assert (not Is_Thunk (Current_Subprogram)); if Nkind (Ret_Obj_Decl) = N_Object_Declaration then Exp := Expression (Ret_Obj_Decl); @@ -4757,9 +4772,9 @@ package body Exp_Ch6 is -- then F and G are both b-i-p, or neither b-i-p. if Nkind (Exp) = N_Function_Call then - pragma Assert (Ekind (Current_Scope) = E_Function); + pragma Assert (Ekind (Current_Subprogram) = E_Function); pragma Assert - (Is_Build_In_Place_Function (Current_Scope) = + (Is_Build_In_Place_Function (Current_Subprogram) = Is_Build_In_Place_Function_Call (Exp)); null; end if; @@ -5010,7 +5025,10 @@ package body Exp_Ch6 is Init_Assignment := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Ret_Obj_Id, Loc), - Expression => New_Copy_Tree (Ret_Obj_Expr)); + Expression => + New_Copy_Tree + (Source => Ret_Obj_Expr, + Scopes_In_EWA_OK => True)); Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); Set_Assignment_OK (Name (Init_Assignment)); @@ -5037,11 +5055,9 @@ package body Exp_Ch6 is -- determine the form of allocation needed, initialization -- is done with each part of the if statement that handles -- the different forms of allocation (this is true for - -- unconstrained and tagged result subtypes). + -- unconstrained, tagged, and controlled result subtypes). - if Is_Constrained (Ret_Typ) - and then not Is_Tagged_Type (Underlying_Type (Ret_Typ)) - then + if not Needs_BIP_Alloc_Form (Func_Id) then Insert_After (Ret_Obj_Decl, Init_Assignment); end if; end if; @@ -5057,16 +5073,14 @@ package body Exp_Ch6 is -- a storage pool. We generate an if statement to test the -- implicit allocation formal and initialize a local access -- value appropriately, creating allocators in the secondary - -- stack and global heap cases. The special formal also exists + -- stack and global heap cases. The special formal also exists -- and must be tested when the function has a tagged result, -- even when the result subtype is constrained, because in -- general such functions can be called in dispatching contexts -- and must be handled similarly to functions with a class-wide -- result. - if not Is_Constrained (Ret_Typ) - or else Is_Tagged_Type (Underlying_Type (Ret_Typ)) - then + if Needs_BIP_Alloc_Form (Func_Id) then Obj_Alloc_Formal := Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); @@ -5145,7 +5159,10 @@ package body Exp_Ch6 is Subtype_Mark => New_Occurrence_Of (Etype (Ret_Obj_Expr), Loc), - Expression => New_Copy_Tree (Ret_Obj_Expr))); + Expression => + New_Copy_Tree + (Source => Ret_Obj_Expr, + Scopes_In_EWA_OK => True))); else -- If the function returns a class-wide type we cannot @@ -5185,7 +5202,11 @@ package body Exp_Ch6 is -- except we set Storage_Pool and Procedure_To_Call so -- it will use the user-defined storage pool. - Pool_Allocator := New_Copy_Tree (Heap_Allocator); + Pool_Allocator := + New_Copy_Tree + (Source => Heap_Allocator, + Scopes_In_EWA_OK => True); + pragma Assert (Alloc_For_BIP_Return (Pool_Allocator)); -- Do not generate the renaming of the build-in-place @@ -5227,7 +5248,11 @@ package body Exp_Ch6 is -- allocation. else - SS_Allocator := New_Copy_Tree (Heap_Allocator); + SS_Allocator := + New_Copy_Tree + (Source => Heap_Allocator, + Scopes_In_EWA_OK => True); + pragma Assert (Alloc_For_BIP_Return (SS_Allocator)); -- The heap and pool allocators are marked as @@ -5331,7 +5356,7 @@ package body Exp_Ch6 is (Global_Heap)))), Then_Statements => New_List ( - Build_Heap_Allocator + Build_Heap_Or_Pool_Allocator (Temp_Id => Alloc_Obj_Id, Temp_Typ => Ref_Type, Func_Id => Func_Id, @@ -5355,7 +5380,7 @@ package body Exp_Ch6 is Then_Statements => New_List ( Pool_Decl, - Build_Heap_Allocator + Build_Heap_Or_Pool_Allocator (Temp_Id => Alloc_Obj_Id, Temp_Typ => Ref_Type, Func_Id => Func_Id, @@ -6362,6 +6387,30 @@ package body Exp_Ch6 is then Rec := New_Occurrence_Of (First_Entity (Current_Scope), Sloc (N)); + -- A default parameter of a protected operation may be a call to + -- a protected function of the type. This appears as an internal + -- call in the profile of the operation, but if the context is an + -- external call we must convert the call into an external one, + -- using the protected object that is the target, so that: + + -- Prot.P (F) + -- is transformed into + -- Prot.P (Prot.F) + + elsif Nkind (Parent (N)) = N_Procedure_Call_Statement + and then Nkind (Name (Parent (N))) = N_Selected_Component + and then Is_Protected_Type (Etype (Prefix (Name (Parent (N))))) + and then Is_Entity_Name (Name (N)) + and then Scope (Entity (Name (N))) = + Etype (Prefix (Name (Parent (N)))) + then + Rewrite (Name (N), + Make_Selected_Component (Sloc (N), + Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))), + Selector_Name => Relocate_Node (Name (N)))); + Analyze_And_Resolve (N); + return; + else -- If the context is the initialization procedure for a protected -- type, the call is legal because the called entity must be a @@ -6774,7 +6823,7 @@ package body Exp_Ch6 is and then (Nkind_In (Exp, N_Type_Conversion, N_Unchecked_Type_Conversion) or else (Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) in Formal_Kind)) + and then Is_Formal (Entity (Exp)))) then -- When the return type is limited, perform a check that the tag of -- the result is the same as the tag of the return type. @@ -6852,7 +6901,7 @@ package body Exp_Ch6 is or else Nkind_In (Exp, N_Type_Conversion, N_Unchecked_Type_Conversion) or else (Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) in Formal_Kind) + and then Is_Formal (Entity (Exp))) or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) then @@ -7256,204 +7305,6 @@ package body Exp_Ch6 is end if; end Expand_Simple_Function_Return; - -------------------------------------------- - -- Has_Unconstrained_Access_Discriminants -- - -------------------------------------------- - - function Has_Unconstrained_Access_Discriminants - (Subtyp : Entity_Id) return Boolean - is - Discr : Entity_Id; - - begin - if Has_Discriminants (Subtyp) - and then not Is_Constrained (Subtyp) - then - Discr := First_Discriminant (Subtyp); - while Present (Discr) loop - if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then - return True; - end if; - - Next_Discriminant (Discr); - end loop; - end if; - - return False; - end Has_Unconstrained_Access_Discriminants; - - ----------------------------------- - -- Is_Build_In_Place_Result_Type -- - ----------------------------------- - - function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is - begin - if not Expander_Active then - return False; - end if; - - -- In Ada 2005 all functions with an inherently limited return type - -- must be handled using a build-in-place profile, including the case - -- of a function with a limited interface result, where the function - -- may return objects of nonlimited descendants. - - if Is_Limited_View (Typ) then - return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L; - - else - if Debug_Flag_Dot_9 then - return False; - end if; - - if Has_Interfaces (Typ) then - return False; - end if; - - declare - T : Entity_Id := Typ; - begin - -- For T'Class, return True if it's True for T. This is necessary - -- because a class-wide function might say "return F (...)", where - -- F returns the corresponding specific type. We need a loop in - -- case T is a subtype of a class-wide type. - - while Is_Class_Wide_Type (T) loop - T := Etype (T); - end loop; - - -- If this is a generic formal type in an instance, return True if - -- it's True for the generic actual type. - - if Nkind (Parent (T)) = N_Subtype_Declaration - and then Present (Generic_Parent_Type (Parent (T))) - then - T := Entity (Subtype_Indication (Parent (T))); - - if Present (Full_View (T)) then - T := Full_View (T); - end if; - end if; - - if Present (Underlying_Type (T)) then - T := Underlying_Type (T); - end if; - - declare - Result : Boolean; - -- So we can stop here in the debugger - begin - -- ???For now, enable build-in-place for a very narrow set of - -- controlled types. Change "if True" to "if False" to - -- experiment with more controlled types. Eventually, we might - -- like to enable build-in-place for all tagged types, all - -- types that need finalization, and all caller-unknown-size - -- types. - - if True then - Result := Is_Controlled (T) - and then Present (Enclosing_Subprogram (T)) - and then not Is_Compilation_Unit (Enclosing_Subprogram (T)) - and then Ekind (Enclosing_Subprogram (T)) = E_Procedure; - else - Result := Is_Controlled (T); - end if; - - return Result; - end; - end; - end if; - end Is_Build_In_Place_Result_Type; - - -------------------------------- - -- Is_Build_In_Place_Function -- - -------------------------------- - - function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is - begin - -- This function is called from Expand_Subtype_From_Expr during - -- semantic analysis, even when expansion is off. In those cases - -- the build_in_place expansion will not take place. - - if not Expander_Active then - return False; - end if; - - -- For now we test whether E denotes a function or access-to-function - -- type whose result subtype is inherently limited. Later this test - -- may be revised to allow composite nonlimited types. Functions with - -- a foreign convention or whose result type has a foreign convention - -- never qualify. - - if Ekind_In (E, E_Function, E_Generic_Function) - or else (Ekind (E) = E_Subprogram_Type - and then Etype (E) /= Standard_Void_Type) - then - -- Note: If the function has a foreign convention, it cannot build - -- its result in place, so you're on your own. On the other hand, - -- if only the return type has a foreign convention, its layout is - -- intended to be compatible with the other language, but the build- - -- in place machinery can ensure that the object is not copied. - - return Is_Build_In_Place_Result_Type (Etype (E)) - and then not Has_Foreign_Convention (E) - and then not Debug_Flag_Dot_L; - - else - return False; - end if; - end Is_Build_In_Place_Function; - - ------------------------------------- - -- Is_Build_In_Place_Function_Call -- - ------------------------------------- - - function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is - Exp_Node : constant Node_Id := Unqual_Conv (N); - Function_Id : Entity_Id; - - begin - -- Return False if the expander is currently inactive, since awareness - -- of build-in-place treatment is only relevant during expansion. Note - -- that Is_Build_In_Place_Function, which is called as part of this - -- function, is also conditioned this way, but we need to check here as - -- well to avoid blowing up on processing protected calls when expansion - -- is disabled (such as with -gnatc) since those would trip over the - -- raise of Program_Error below. - - -- In SPARK mode, build-in-place calls are not expanded, so that we - -- may end up with a call that is neither resolved to an entity, nor - -- an indirect call. - - if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then - return False; - end if; - - if Is_Entity_Name (Name (Exp_Node)) then - Function_Id := Entity (Name (Exp_Node)); - - -- In the case of an explicitly dereferenced call, use the subprogram - -- type generated for the dereference. - - elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then - Function_Id := Etype (Name (Exp_Node)); - - -- This may be a call to a protected function. - - elsif Nkind (Name (Exp_Node)) = N_Selected_Component then - Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node)))); - - else - raise Program_Error; - end if; - - declare - Result : constant Boolean := Is_Build_In_Place_Function (Function_Id); - -- So we can stop here in the debugger - begin - return Result; - end; - end Is_Build_In_Place_Function_Call; - ----------------------- -- Freeze_Subprogram -- ----------------------- @@ -7646,6 +7497,32 @@ package body Exp_Ch6 is end if; end Freeze_Subprogram; + -------------------------------------------- + -- Has_Unconstrained_Access_Discriminants -- + -------------------------------------------- + + function Has_Unconstrained_Access_Discriminants + (Subtyp : Entity_Id) return Boolean + is + Discr : Entity_Id; + + begin + if Has_Discriminants (Subtyp) + and then not Is_Constrained (Subtyp) + then + Discr := First_Discriminant (Subtyp); + while Present (Discr) loop + if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then + return True; + end if; + + Next_Discriminant (Discr); + end loop; + end if; + + return False; + end Has_Unconstrained_Access_Discriminants; + ------------------------------ -- Insert_Post_Call_Actions -- ------------------------------ @@ -7768,6 +7645,177 @@ package body Exp_Ch6 is end if; end Insert_Post_Call_Actions; + ----------------------------------- + -- Is_Build_In_Place_Result_Type -- + ----------------------------------- + + function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is + begin + if not Expander_Active then + return False; + end if; + + -- In Ada 2005 all functions with an inherently limited return type + -- must be handled using a build-in-place profile, including the case + -- of a function with a limited interface result, where the function + -- may return objects of nonlimited descendants. + + if Is_Limited_View (Typ) then + return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L; + + else + if Debug_Flag_Dot_9 then + return False; + end if; + + if Has_Interfaces (Typ) then + return False; + end if; + + declare + T : Entity_Id := Typ; + begin + -- For T'Class, return True if it's True for T. This is necessary + -- because a class-wide function might say "return F (...)", where + -- F returns the corresponding specific type. We need a loop in + -- case T is a subtype of a class-wide type. + + while Is_Class_Wide_Type (T) loop + T := Etype (T); + end loop; + + -- If this is a generic formal type in an instance, return True if + -- it's True for the generic actual type. + + if Nkind (Parent (T)) = N_Subtype_Declaration + and then Present (Generic_Parent_Type (Parent (T))) + then + T := Entity (Subtype_Indication (Parent (T))); + + if Present (Full_View (T)) then + T := Full_View (T); + end if; + end if; + + if Present (Underlying_Type (T)) then + T := Underlying_Type (T); + end if; + + declare + Result : Boolean; + -- So we can stop here in the debugger + begin + -- ???For now, enable build-in-place for a very narrow set of + -- controlled types. Change "if True" to "if False" to + -- experiment with more controlled types. Eventually, we might + -- like to enable build-in-place for all tagged types, all + -- types that need finalization, and all caller-unknown-size + -- types. + + if True then + Result := Is_Controlled (T) + and then Present (Enclosing_Subprogram (T)) + and then not Is_Compilation_Unit (Enclosing_Subprogram (T)) + and then Ekind (Enclosing_Subprogram (T)) = E_Procedure; + else + Result := Is_Controlled (T); + end if; + + return Result; + end; + end; + end if; + end Is_Build_In_Place_Result_Type; + + -------------------------------- + -- Is_Build_In_Place_Function -- + -------------------------------- + + function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is + begin + -- This function is called from Expand_Subtype_From_Expr during + -- semantic analysis, even when expansion is off. In those cases + -- the build_in_place expansion will not take place. + + if not Expander_Active then + return False; + end if; + + -- For now we test whether E denotes a function or access-to-function + -- type whose result subtype is inherently limited. Later this test + -- may be revised to allow composite nonlimited types. Functions with + -- a foreign convention or whose result type has a foreign convention + -- never qualify. + + if Ekind_In (E, E_Function, E_Generic_Function) + or else (Ekind (E) = E_Subprogram_Type + and then Etype (E) /= Standard_Void_Type) + then + -- Note: If the function has a foreign convention, it cannot build + -- its result in place, so you're on your own. On the other hand, + -- if only the return type has a foreign convention, its layout is + -- intended to be compatible with the other language, but the build- + -- in place machinery can ensure that the object is not copied. + + return Is_Build_In_Place_Result_Type (Etype (E)) + and then not Has_Foreign_Convention (E) + and then not Debug_Flag_Dot_L; + else + return False; + end if; + end Is_Build_In_Place_Function; + + ------------------------------------- + -- Is_Build_In_Place_Function_Call -- + ------------------------------------- + + function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is + Exp_Node : constant Node_Id := Unqual_Conv (N); + Function_Id : Entity_Id; + + begin + -- Return False if the expander is currently inactive, since awareness + -- of build-in-place treatment is only relevant during expansion. Note + -- that Is_Build_In_Place_Function, which is called as part of this + -- function, is also conditioned this way, but we need to check here as + -- well to avoid blowing up on processing protected calls when expansion + -- is disabled (such as with -gnatc) since those would trip over the + -- raise of Program_Error below. + + -- In SPARK mode, build-in-place calls are not expanded, so that we + -- may end up with a call that is neither resolved to an entity, nor + -- an indirect call. + + if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then + return False; + end if; + + if Is_Entity_Name (Name (Exp_Node)) then + Function_Id := Entity (Name (Exp_Node)); + + -- In the case of an explicitly dereferenced call, use the subprogram + -- type generated for the dereference. + + elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then + Function_Id := Etype (Name (Exp_Node)); + + -- This may be a call to a protected function. + + elsif Nkind (Name (Exp_Node)) = N_Selected_Component then + Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node)))); + + else + raise Program_Error; + end if; + + declare + Result : constant Boolean := Is_Build_In_Place_Function (Function_Id); + -- So we can stop here in the debugger + begin + return Result; + end; + end Is_Build_In_Place_Function_Call; + ----------------------- -- Is_Null_Procedure -- ----------------------- @@ -7853,10 +7901,9 @@ package body Exp_Ch6 is -- Step past qualification or unchecked conversion (the latter can occur -- in cases of calls to 'Input). - if Nkind_In (Func_Call, - N_Qualified_Expression, - N_Type_Conversion, - N_Unchecked_Type_Conversion) + if Nkind_In (Func_Call, N_Qualified_Expression, + N_Type_Conversion, + N_Unchecked_Type_Conversion) then Func_Call := Expression (Func_Call); end if; @@ -7889,16 +7936,37 @@ package body Exp_Ch6 is Set_Can_Never_Be_Null (Acc_Type, False); -- It gets initialized to null, so we can't have that - -- When the result subtype is constrained, the return object is - -- allocated on the caller side, and access to it is passed to the - -- function. + -- When the result subtype is constrained, the return object is created + -- on the caller side, and access to it is passed to the function. This + -- optimization is disabled when the result subtype needs finalization + -- actions because the caller side allocation may result in undesirable + -- finalization. Consider the following example: + -- + -- function Make_Lim_Ctrl return Lim_Ctrl is + -- begin + -- return Result : Lim_Ctrl := raise Program_Error do + -- null; + -- end return; + -- end Make_Lim_Ctrl; + -- + -- Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl); + -- + -- Even though the size of limited controlled type Lim_Ctrl is known, + -- allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's + -- finalization master. The subsequent call to Make_Lim_Ctrl will fail + -- during the initialization actions for Result, which implies that + -- Result (and Obj by extension) should not be finalized. However Obj + -- will be finalized when access type Lim_Ctrl_Ptr goes out of scope + -- since it is already attached on the related finalization master. -- Here and in related routines, we must examine the full view of the -- type, because the view at the point of call may differ from that -- that in the function body, and the expansion mechanism depends on -- the characteristics of the full view. - if Is_Constrained (Underlying_Type (Result_Subt)) then + if Is_Constrained (Underlying_Type (Result_Subt)) + and then not Needs_Finalization (Underlying_Type (Result_Subt)) + then -- Replace the initialized allocator of form "new T'(Func (...))" -- with an uninitialized allocator of form "new T", where T is the -- result subtype of the called function. The call to the function @@ -7926,8 +7994,8 @@ package body Exp_Ch6 is Temp_Init := Relocate_Node (Allocator); - if Nkind_In - (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion) + if Nkind_In (Function_Call, N_Type_Conversion, + N_Unchecked_Type_Conversion) then Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init); end if; @@ -8001,17 +8069,17 @@ package body Exp_Ch6 is -- that the full types will be compatible, but the types not visibly -- compatible. - elsif Nkind_In - (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion) + elsif Nkind_In (Function_Call, N_Type_Conversion, + N_Unchecked_Type_Conversion) then Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call); end if; declare Assign : constant Node_Id := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Return_Obj_Access, Loc), - Expression => Ref_Func_Call); + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Return_Obj_Access, Loc), + Expression => Ref_Func_Call); -- Assign the result of the function call into the temp. In the -- caller-allocates case, this is overwriting the temp with its -- initial value, which has no effect. In the callee-allocates case, @@ -8025,6 +8093,7 @@ package body Exp_Ch6 is -- to wrap the assignment in a block that activates them. The -- activation chain of that block must be passed to the function, -- rather than some outer chain. + begin if Has_Task (Result_Subt) then Actions := New_List; @@ -9062,8 +9131,30 @@ package body Exp_Ch6 is function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is pragma Assert (Is_Build_In_Place_Function (Func_Id)); Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); + begin - return not Is_Constrained (Func_Typ) or else Is_Tagged_Type (Func_Typ); + -- A build-in-place function needs to know which allocation form to + -- use when: + -- + -- 1) The result subtype is unconstrained. In this case, depending on + -- the context of the call, the object may need to be created in the + -- secondary stack, the heap, or a user-defined storage pool. + -- + -- 2) The result subtype is tagged. In this case the function call may + -- dispatch on result and thus needs to be treated in the same way as + -- calls to functions with class-wide results, because a callee that + -- can be dispatched to may have any of various result subtypes, so + -- if any of the possible callees would require an allocation form to + -- be passed then they all do. + -- + -- 3) The result subtype needs finalization actions. In this case, based + -- on the context of the call, the object may need to be created at + -- the caller site, in the heap, or in a user-defined storage pool. + + return + not Is_Constrained (Func_Typ) + or else Is_Tagged_Type (Func_Typ) + or else Needs_Finalization (Func_Typ); end Needs_BIP_Alloc_Form; -------------------------------------- diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index c3707bb..1b8b8f2 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -3984,32 +3984,145 @@ package body Exp_Ch7 is end if; end Cleanup_Task; - ----------------------------------- + -------------------------------------- -- Check_Unnesting_Elaboration_Code -- - ----------------------------------- + -------------------------------------- procedure Check_Unnesting_Elaboration_Code (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); + + function Contains_Subprogram (Blk : Entity_Id) return Boolean; + -- Check recursively whether a loop or block contains a subprogram that + -- may need an activation record. + + function First_Local_Scope (L : List_Id) return Entity_Id; + -- Find first block or loop that contains a subprogram and is not itself + -- nested within another local scope. + + -------------------------- + -- Contains_Subprogram -- + -------------------------- + + function Contains_Subprogram (Blk : Entity_Id) return Boolean is + E : Entity_Id; + + begin + E := First_Entity (Blk); + + while Present (E) loop + if Is_Subprogram (E) then + return True; + + elsif Ekind_In (E, E_Block, E_Loop) + and then Contains_Subprogram (E) + then + return True; + end if; + + Next_Entity (E); + end loop; + + return False; + end Contains_Subprogram; + + ----------------------- + -- Find_Local_Scope -- + ----------------------- + + function First_Local_Scope (L : List_Id) return Entity_Id is + Stat : Node_Id; + Scop : Entity_Id; + + begin + Stat := First (L); + while Present (Stat) loop + case Nkind (Stat) is + when N_Block_Statement => + if Present (Identifier (Stat)) then + return Entity (Identifier (Stat)); + end if; + + when N_Loop_Statement => + if Contains_Subprogram (Entity (Identifier (Stat))) then + return Entity (Identifier (Stat)); + end if; + + when N_If_Statement => + Scop := First_Local_Scope (Then_Statements (Stat)); + + if Present (Scop) then + return Scop; + end if; + + Scop := First_Local_Scope (Else_Statements (Stat)); + + if Present (Scop) then + return Scop; + end if; + + declare + Elif : Node_Id; + begin + Elif := First (Elsif_Parts (Stat)); + + while Present (Elif) loop + Scop := First_Local_Scope (Statements (Elif)); + + if Present (Scop) then + return Scop; + end if; + + Next (Elif); + end loop; + end; + + when N_Case_Statement => + declare + Alt : Node_Id; + begin + Alt := First (Alternatives (Stat)); + + while Present (Alt) loop + Scop := First_Local_Scope (Statements (Alt)); + + if Present (Scop) then + return Scop; + end if; + + Next (Alt); + end loop; + end; + + when N_Subprogram_Body => + return Defining_Entity (Stat); + + when others => + null; + end case; + Next (Stat); + end loop; + + return Empty; + end First_Local_Scope; + + -- Local variables + Elab_Body : Node_Id; Elab_Call : Node_Id; Elab_Proc : Entity_Id; - Stat : Node_Id; + Ent : Entity_Id; + + -- Start of processing for Check_Unnesting_Elaboration_Code begin if Unnest_Subprogram_Mode and then Present (Handled_Statement_Sequence (N)) and then Is_Compilation_Unit (Current_Scope) then - Stat := First (Statements (Handled_Statement_Sequence (N))); - while Present (Stat) loop - if Nkind (Stat) = N_Block_Statement then - exit; - end if; + Ent := First_Local_Scope + (Statements (Handled_Statement_Sequence (N))); - Next (Stat); - end loop; - - if Present (Stat) then + if Present (Ent) then Elab_Proc := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('I')); @@ -4037,20 +4150,14 @@ package body Exp_Ch7 is Analyze (Elab_Call); - -- The scope of all blocks in the elaboration code is now the - -- constructed elaboration procedure. Nested subprograms within - -- those blocks will have activation records if they contain - -- references to entities in the enclosing block. - - Stat := - First (Statements (Handled_Statement_Sequence (Elab_Body))); - - while Present (Stat) loop - if Nkind (Stat) = N_Block_Statement then - Set_Scope (Entity (Identifier (Stat)), Elab_Proc); - end if; + -- The scope of all blocks and loops in the elaboration code is + -- now the constructed elaboration procedure. Nested subprograms + -- within those blocks will have activation records if they + -- contain references to entities in the enclosing block. - Next (Stat); + while Present (Ent) loop + Set_Scope (Ent, Elab_Proc); + Next_Entity (Ent); end loop; end if; end if; @@ -8664,6 +8771,9 @@ package body Exp_Ch7 is function Manages_Sec_Stack (Id : Entity_Id) return Boolean; -- Determine whether scoping entity Id manages the secondary stack + function Within_Loop_Statement (N : Node_Id) return Boolean; + -- Return True when N appears within a loop and no block is containing N + ----------------------- -- Manages_Sec_Stack -- ----------------------- @@ -8693,6 +8803,26 @@ package body Exp_Ch7 is end case; end Manages_Sec_Stack; + --------------------------- + -- Within_Loop_Statement -- + --------------------------- + + function Within_Loop_Statement (N : Node_Id) return Boolean is + Par : Node_Id := Parent (N); + + begin + while not (Nkind_In (Par, N_Handled_Sequence_Of_Statements, + N_Loop_Statement, + N_Package_Specification) + or else Nkind (Par) in N_Proper_Body) + loop + pragma Assert (Present (Par)); + Par := Parent (Par); + end loop; + + return Nkind (Par) = N_Loop_Statement; + end Within_Loop_Statement; + -- Local variables Decls : constant List_Id := New_List; @@ -8746,6 +8876,16 @@ package body Exp_Ch7 is elsif Ekind (Scop) = E_Loop then exit; + -- Ditto when the block appears without a block that does not + -- manage the secondary stack and is located within a loop. + + elsif Ekind (Scop) = E_Block + and then not Manages_Sec_Stack (Scop) + and then Present (Block_Node (Scop)) + and then Within_Loop_Statement (Block_Node (Scop)) + then + exit; + -- The transient block does not need to manage the secondary stack -- when there is an enclosing construct which already does that. -- This optimization saves on SS_Mark and SS_Release calls but may diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 981c0ee..e7561df 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; @@ -53,6 +54,7 @@ with Sem_Ch9; use Sem_Ch9; with Sem_Ch11; use Sem_Ch11; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -290,7 +292,7 @@ package body Exp_Ch9 is (N : Node_Id; Pid : Node_Id) return Node_Id; -- This routine constructs the unprotected version of a protected - -- subprogram body, which is contains all of the code in the original, + -- subprogram body, which contains all of the code in the original, -- unexpanded body. This is the version of the protected subprogram that is -- called from all protected operations on the same object, including the -- protected version of the same subprogram. @@ -474,6 +476,11 @@ package body Exp_Ch9 is -- ... -- <actualN> := P.<formalN>; + procedure Reset_Scopes_To (Proc_Body : Node_Id; E : Entity_Id); + -- Reset the scope of declarations and blocks at the top level of Proc_Body + -- to be E. Used after expanding entry bodies into their corresponding + -- procedures. + function Trivial_Accept_OK return Boolean; -- If there is no DO-END block for an accept, or if the DO-END block has -- only null statements, then it is possible to do the Rendezvous with much @@ -3478,14 +3485,95 @@ package body Exp_Ch9 is function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id is + procedure Analyze_Pragmas (From : Node_Id); + -- Analyze all pragmas which follow arbitrary node From + + procedure Move_Pragmas (From : Node_Id; To : Node_Id); + -- Find all suitable source pragmas at the top of subprogram body From's + -- declarations and insert them after arbitrary node To. + + --------------------- + -- Analyze_Pragmas -- + --------------------- + + procedure Analyze_Pragmas (From : Node_Id) is + Decl : Node_Id; + + begin + Decl := Next (From); + while Present (Decl) loop + if Nkind (Decl) = N_Pragma then + Analyze_Pragma (Decl); + + -- No candidate pragmas are available for analysis + + else + exit; + end if; + + Next (Decl); + end loop; + end Analyze_Pragmas; + + ------------------ + -- Move_Pragmas -- + ------------------ + + procedure Move_Pragmas (From : Node_Id; To : Node_Id) is + Decl : Node_Id; + Insert_Nod : Node_Id; + Next_Decl : Node_Id; + + begin + pragma Assert (Nkind (From) = N_Subprogram_Body); + + -- The pragmas are moved in an order-preserving fashion + + Insert_Nod := To; + + -- Inspect the declarations of the subprogram body and relocate all + -- candidate pragmas. + + Decl := First (Declarations (From)); + while Present (Decl) loop + + -- Preserve the following declaration for iteration purposes, due + -- to possible relocation of a pragma. + + Next_Decl := Next (Decl); + + if Nkind (Decl) = N_Pragma then + Remove (Decl); + Insert_After (Insert_Nod, Decl); + Insert_Nod := Decl; + + -- Skip internally generated code + + elsif not Comes_From_Source (Decl) then + null; + + -- No candidate pragmas are available for relocation + + else + exit; + end if; + + Decl := Next_Decl; + end loop; + end Move_Pragmas; + + -- Local variables + + Body_Id : constant Entity_Id := Defining_Entity (N); Loc : constant Source_Ptr := Sloc (N); - Body_Id : constant Entity_Id := Defining_Entity (N); Decl : Node_Id; - Plist : List_Id; Formal : Entity_Id; - New_Spec : Node_Id; + Formals : List_Id; + Spec : Node_Id; Spec_Id : Entity_Id; + -- Start of processing for Build_Private_Protected_Declaration + begin Formal := First_Formal (Body_Id); @@ -3494,43 +3582,61 @@ package body Exp_Ch9 is -- expansion is enabled. if Present (Formal) or else Expander_Active then - Plist := Copy_Parameter_List (Body_Id); + Formals := Copy_Parameter_List (Body_Id); else - Plist := No_List; + Formals := No_List; end if; + Spec_Id := + Make_Defining_Identifier (Sloc (Body_Id), + Chars => Chars (Body_Id)); + + -- Indicate that the entity comes from source, to ensure that cross- + -- reference information is properly generated. The body itself is + -- rewritten during expansion, and the body entity will not appear in + -- calls to the operation. + + Set_Comes_From_Source (Spec_Id, True); + if Nkind (Specification (N)) = N_Procedure_Specification then - New_Spec := + Spec := Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Sloc (Body_Id), - Chars => Chars (Body_Id)), - Parameter_Specifications => - Plist); + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Formals); else - New_Spec := + Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Sloc (Body_Id), - Chars => Chars (Body_Id)), - Parameter_Specifications => Plist, + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Formals, Result_Definition => New_Occurrence_Of (Etype (Body_Id), Loc)); end if; - Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec); + Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); + Set_Corresponding_Body (Decl, Body_Id); + Set_Corresponding_Spec (N, Spec_Id); + Insert_Before (N, Decl); - Spec_Id := Defining_Unit_Name (New_Spec); - -- Indicate that the entity comes from source, to ensure that cross- - -- reference information is properly generated. The body itself is - -- rewritten during expansion, and the body entity will not appear in - -- calls to the operation. + -- Associate all aspects and pragmas of the body with the spec. This + -- ensures that these annotations apply to the initial declaration of + -- the subprogram body. + + Move_Aspects (From => N, To => Decl); + Move_Pragmas (From => N, To => Decl); - Set_Comes_From_Source (Spec_Id, True); Analyze (Decl); + + -- The analysis of the spec may generate pragmas which require manual + -- analysis. Since the generation of the spec and the relocation of the + -- annotations is driven by the expansion of the stand-alone body, the + -- pragmas will not be analyzed in a timely manner. Do this now. + + Analyze_Pragmas (Decl); + + Set_Convention (Spec_Id, Convention_Protected); Set_Has_Completion (Spec_Id); - Set_Convention (Spec_Id, Convention_Protected); + return Spec_Id; end Build_Private_Protected_Declaration; @@ -3558,6 +3664,7 @@ package body Exp_Ch9 is Bod_Stmts : List_Id; Complete : Node_Id; Ohandle : Node_Id; + Proc_Body : Node_Id; EH_Loc : Source_Ptr; -- Used for the exception handler, inserted at end of the body @@ -3670,7 +3777,7 @@ package body Exp_Ch9 is -- Create body of entry procedure. The renaming declarations are -- placed ahead of the block that contains the actual entry body. - return + Proc_Body := Make_Subprogram_Body (Loc, Specification => Bod_Spec, Declarations => Bod_Decls, @@ -3699,6 +3806,9 @@ package body Exp_Ch9 is Name => New_Occurrence_Of (RTE (RE_Get_GNAT_Exception), Loc))))))))); + + Reset_Scopes_To (Proc_Body, Bod_Id); + return Proc_Body; end if; end Build_Protected_Entry; @@ -8653,8 +8763,12 @@ package body Exp_Ch9 is when N_Implicit_Label_Declaration => null; - when N_Itype_Reference => - Insert_After (Current_Node, New_Copy (Op_Body)); + when N_Call_Marker + | N_Itype_Reference + => + New_Op_Body := New_Copy (Op_Body); + Insert_After (Current_Node, New_Op_Body); + Current_Node := New_Op_Body; when N_Freeze_Entity => New_Op_Body := New_Copy (Op_Body); @@ -10544,11 +10658,14 @@ package body Exp_Ch9 is Eloc : constant Source_Ptr := Sloc (Ename); Eent : constant Entity_Id := Entity (Ename); Index : constant Node_Id := Entry_Index (Acc_Stm); + + Call : Node_Id; + Expr : Node_Id; Null_Body : Node_Id; - Proc_Body : Node_Id; PB_Ent : Entity_Id; - Expr : Node_Id; - Call : Node_Id; + Proc_Body : Node_Id; + + -- Start of processing for Add_Accept begin if No (Ann) then @@ -10562,9 +10679,7 @@ package body Exp_Ch9 is Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)), New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc))); else - Expr := - Entry_Index_Expression - (Eloc, Eent, Index, Scope (Eent)); + Expr := Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)); end if; if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then @@ -10606,6 +10721,8 @@ package body Exp_Ch9 is Handled_Statement_Sequence => Build_Accept_Body (Accept_Statement (Alt))); + Reset_Scopes_To (Proc_Body, PB_Ent); + -- During the analysis of the body of the accept statement, any -- zero cost exception handler records were collected in the -- Accept_Handler_Records field of the N_Accept_Alternative node. @@ -14709,6 +14826,64 @@ package body Exp_Ch9 is end if; end Parameter_Block_Unpack; + --------------------- + -- Reset_Scopes_To -- + --------------------- + + procedure Reset_Scopes_To (Proc_Body : Node_Id; E : Entity_Id) is + function Reset_Scope (N : Node_Id) return Traverse_Result; + -- Temporaries may have been declared during expansion of the procedure + -- alternative. Indicate that their scope is the new body, to prevent + -- generation of spurious uplevel references for these entities. + + procedure Reset_Scopes is new Traverse_Proc (Reset_Scope); + + ----------------- + -- Reset_Scope -- + ----------------- + + function Reset_Scope (N : Node_Id) return Traverse_Result is + Decl : Node_Id; + + begin + -- If this is a block statement with an Identifier, it forms a scope, + -- so we want to reset its scope but not look inside. + + if Nkind (N) = N_Block_Statement + and then Present (Identifier (N)) + then + Set_Scope (Entity (Identifier (N)), E); + return Skip; + + elsif Nkind (N) = N_Package_Declaration then + Set_Scope (Defining_Entity (N), E); + return Skip; + + elsif N = Proc_Body then + + -- Scan declarations + + Decl := First (Declarations (N)); + while Present (Decl) loop + Reset_Scopes (Decl); + Next (Decl); + end loop; + + elsif N /= Proc_Body and then Nkind (N) in N_Proper_Body then + return Skip; + elsif Nkind (N) = N_Defining_Identifier then + Set_Scope (N, E); + end if; + + return OK; + end Reset_Scope; + + -- Start of processing for Reset_Scopes_To + + begin + Reset_Scopes (Proc_Body); + end Reset_Scopes_To; + ---------------------- -- Set_Discriminals -- ---------------------- diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index dbccfed..8270492 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -809,7 +809,7 @@ package body Exp_Disp is Prec := Next_Pragma (Prec); end loop; - if No (Prec) then + if No (Prec) or else Is_Ignored (Prec) then return; end if; @@ -7179,7 +7179,7 @@ package body Exp_Disp is Analyze_List (Result); -- Generate: - -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr; + -- subtype Typ_DT is Address_Array (1 .. Nb_Prims); -- type Typ_DT_Acc is access Typ_DT; else @@ -7196,25 +7196,25 @@ package body Exp_Disp is Name_DT_Prims_Acc); begin Append_To (Result, - Make_Full_Type_Declaration (Loc, + Make_Subtype_Declaration (Loc, Defining_Identifier => DT_Prims, - Type_Definition => - Make_Constrained_Array_Definition (Loc, - Discrete_Subtype_Definitions => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Make_Integer_Literal (Loc, - DT_Entry_Count - (First_Tag_Component (Typ))))), - Component_Definition => - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Prim_Ptr), Loc))))); + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Address_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Integer_Literal (Loc, + DT_Entry_Count + (First_Tag_Component (Typ))))))))); Append_To (Result, Make_Full_Type_Declaration (Loc, Defining_Identifier => DT_Prims_Acc, - Type_Definition => + Type_Definition => Make_Access_To_Object_Definition (Loc, Subtype_Indication => New_Occurrence_Of (DT_Prims, Loc)))); @@ -8181,7 +8181,8 @@ package body Exp_Disp is function Gen_Parameters_Profile (E : Entity_Id) return List_Id; -- Duplicate the parameters profile of the imported C++ constructor - -- adding an access to the object as an additional parameter. + -- adding the "this" pointer to the object as the additional first + -- parameter under the usual form _Init : in out Typ. ---------------------------- -- Gen_Parameters_Profile -- @@ -8198,6 +8199,8 @@ package body Exp_Disp is Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit), + In_Present => True, + Out_Present => True, Parameter_Type => New_Occurrence_Of (Typ, Loc))); if Present (Parameter_Specifications (Parent (E))) then @@ -8244,9 +8247,7 @@ package body Exp_Disp is Found := True; Loc := Sloc (E); Parms := Gen_Parameters_Profile (E); - IP := - Make_Defining_Identifier (Loc, - Chars => Make_Init_Proc_Name (Typ)); + IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); -- Case 1: Constructor of untagged type @@ -8273,14 +8274,14 @@ package body Exp_Disp is -- Case 2: Constructor of a tagged type - -- In this case we generate the IP as a wrapper of the the - -- C++ constructor because IP must also save copy of the _tag + -- In this case we generate the IP routine as a wrapper of the + -- C++ constructor because IP must also save a copy of the _tag -- generated in the C++ side. The copy of the _tag is used by -- Build_CPP_Init_Procedure to elaborate derivations of C++ types. -- Generate: - -- procedure IP (_init : Typ; ...) is - -- procedure ConstructorP (_init : Typ; ...); + -- procedure IP (_init : in out Typ; ...) is + -- procedure ConstructorP (_init : in out Typ; ...); -- pragma Import (ConstructorP); -- begin -- ConstructorP (_init, ...); @@ -8352,7 +8353,7 @@ package body Exp_Disp is loop -- Skip the following assertion with primary tags -- because Related_Type is not set on primary tag - -- components + -- components. pragma Assert (Tag_Comp = First_Tag_Component (Typ) diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 17277a9..65cfe1f 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -44,6 +44,7 @@ with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch8; use Sem_Ch8; +with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; @@ -167,11 +168,24 @@ package body Exp_Prag is Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname); begin - -- Rewrite pragma ignored by Ignore_Pragma to null statement, so that - -- the back end doesn't see it. The same goes for pragma - -- Default_Scalar_Storage_Order if the -gnatI switch was given. + -- Suppress the expansion of an ignored assertion pragma. Such a pragma + -- should not be transformed into a null statment because: + -- + -- * The pragma may be part of the rep item chain of a type, in which + -- case rewriting it will destroy the chain. + -- + -- * The analysis of the pragma may involve two parts (see routines + -- Analyze_xxx_In_Decl_Part). The second part of the analysis will + -- not happen if the pragma is rewritten. + + if Assertion_Expression_Pragma (Prag_Id) and then Is_Ignored (N) then + return; + + -- Rewrite the pragma into a null statement when it is ignored using + -- pragma Ignore_Pragma, or denotes Default_Scalar_Storage_Order and + -- compilation switch -gnatI is in effect. - if Should_Ignore_Pragma_Sem (N) + elsif Should_Ignore_Pragma_Sem (N) or else (Prag_Id = Pragma_Default_Scalar_Storage_Order and then Ignore_Rep_Clauses) then diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index c6d49e0..c5b03c4 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -98,6 +98,23 @@ package body Exp_Unst is -- Append a call entry to the Calls table. A check is made to see if the -- table already contains this entry and if so it has no effect. + ---------------------------------- + -- Subprograms For Fat Pointers -- + ---------------------------------- + + function Build_Access_Type_Decl + (E : Entity_Id; + Scop : Entity_Id) return Node_Id; + -- For an uplevel reference that involves an unconstrained array type, + -- build an access type declaration for the corresponding activation + -- record component. The relevant attributes of the access type are + -- set here to avoid a full analysis that would require a scope stack. + + function Needs_Fat_Pointer (E : Entity_Id) return Boolean; + -- A formal parameter of an unconstrained array type that appears in an + -- uplevel reference requires the construction of an access type, to be + -- used in the corresponding component declaration. + ----------- -- Urefs -- ----------- @@ -152,6 +169,32 @@ package body Exp_Unst is Calls.Append (Call); end Append_Unique_Call; + ----------------------------- + -- Build_Access_Type_Decl -- + ----------------------------- + + function Build_Access_Type_Decl + (E : Entity_Id; + Scop : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (E); + Typ : Entity_Id; + + begin + Typ := Make_Temporary (Loc, 'S'); + Set_Ekind (Typ, E_General_Access_Type); + Set_Etype (Typ, Typ); + Set_Scope (Typ, Scop); + Set_Directly_Designated_Type (Typ, Etype (E)); + + return + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => New_Occurrence_Of (Etype (E), Loc))); + end Build_Access_Type_Decl; + --------------- -- Get_Level -- --------------- @@ -192,6 +235,17 @@ package body Exp_Unst is return False; end In_Synchronized_Unit; + ----------------------- + -- Needs_Fat_Pointer -- + ----------------------- + + function Needs_Fat_Pointer (E : Entity_Id) return Boolean is + begin + return Is_Formal (E) + and then Is_Array_Type (Etype (E)) + and then not Is_Constrained (Etype (E)); + end Needs_Fat_Pointer; + ---------------- -- Subp_Index -- ---------------- @@ -205,6 +259,16 @@ package body Exp_Unst is if Subps_Index (E) = Uint_0 then E := Ultimate_Alias (E); + -- The body of a protected operation has a different name and + -- has been scanned at this point, and thus has an entry in + -- the subprogram table. + + if E = Sub + and then Convention (E) = Convention_Protected + then + E := Protected_Body_Subprogram (E); + end if; + if Ekind (E) = E_Function and then Rewritten_For_C (E) and then Present (Corresponding_Procedure (E)) @@ -440,12 +504,13 @@ package body Exp_Unst is 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)) /= E_Discriminant then Note_Uplevel_Ref (E => Entity (N), - N => Ref, + N => Empty, Caller => Current_Subprogram, Callee => Enclosing_Subprogram (Entity (N))); end if; @@ -472,6 +537,26 @@ package body Exp_Unst is end loop; end; + -- 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_In (N, + N_Explicit_Dereference, + N_Selected_Component) + then + Note_Uplevel_Bound (Prefix (N), Ref); + -- Conversion case elsif Nkind (N) = N_Type_Conversion then @@ -641,11 +726,19 @@ package body Exp_Unst is L : constant Nat := Get_Level (Subp, E); begin + -- Subprograms declared in tasks and protected types cannot + -- be eliminated because calls to them may be in other units, + -- so they must be treated as reachable. + Subps.Append ((Ent => E, Bod => Bod, Lev => L, - Reachable => False, + Reachable => In_Synchronized_Unit (E), + + -- Subprograms declared in tasks and protected types are + -- reachable and cannot be eliminated. + Uplevel_Ref => L, Declares_AREC => False, Uents => No_Elist, @@ -737,7 +830,7 @@ package body Exp_Unst is -- Similarly, the following constructs include a semantic -- attribute Procedure_To_Call that must be handled like - -- other calls. + -- other calls. Likewise for attribute Storage_Pool. when N_Allocator | N_Extended_Return_Statement @@ -745,7 +838,9 @@ package body Exp_Unst is | N_Simple_Return_Statement => declare + Pool : constant Entity_Id := Storage_Pool (N); Proc : constant Entity_Id := Procedure_To_Call (N); + begin if Present (Proc) and then Scope_Within (Proc, Subp) @@ -753,9 +848,51 @@ package body Exp_Unst is then Append_Unique_Call ((N, Current_Subprogram, Proc)); end if; + + if Present (Pool) + and then not Is_Library_Level_Entity (Pool) + and then Scope_Within_Or_Same (Scope (Pool), Subp) + then + Caller := Current_Subprogram; + Callee := Enclosing_Subprogram (Pool); + + if Callee /= Caller then + Note_Uplevel_Ref (Pool, Empty, Caller, Callee); + end if; + end if; end; - -- A 'Access reference is a (potential) call. Other attributes + -- For an allocator with a qualified expression, check type + -- of expression being qualified. The explicit type name is + -- handled as an entity reference. + + if Nkind (N) = N_Allocator + and then Nkind (Expression (N)) = N_Qualified_Expression + then + declare + DT : Boolean := False; + begin + Check_Static_Type + (Etype (Expression (Expression (N))), Empty, DT); + end; + + -- For a Return or Free (all other nodes we handle here), + -- we usually need the size of the object, so we need to be + -- sure that any nonstatic bounds of the expression's type + -- that are uplevel are handled. + + elsif Nkind (N) /= N_Allocator + and then Present (Expression (N)) + then + declare + DT : Boolean := False; + begin + Check_Static_Type (Etype (Expression (N)), Empty, DT); + end; + end if; + + -- A 'Access reference is a (potential) call. So is 'Address, + -- in particular on imported subprograms. Other attributes -- require special handling. when N_Attribute_Reference => @@ -767,6 +904,7 @@ package body Exp_Unst is when Attribute_Access | Attribute_Unchecked_Access | Attribute_Unrestricted_Access + | Attribute_Address => if Nkind (Prefix (N)) in N_Has_Entity then Ent := Entity (Prefix (N)); @@ -821,15 +959,26 @@ package body Exp_Unst is -- no relevant code generation. when N_Component_Association => - if No (Etype (Expression (N))) then + if No (Expression (N)) + or else No (Etype (Expression (N))) + then return Skip; end if; + -- Generic associations are not analyzed: the actuals are + -- transferred to renaming and subtype declarations that + -- are the ones that must be examined. + + when N_Generic_Association => + return Skip; + -- Indexed references can be uplevel if the type isn't static -- and if the lower bound (or an inner bound for a multi- -- dimensional array) is uplevel. - when N_Indexed_Component | N_Slice => + when N_Indexed_Component + | N_Slice + => if Is_Constrained (Etype (Prefix (N))) then declare DT : Boolean := False; @@ -856,6 +1005,31 @@ package body Exp_Unst is end; end if; + -- For EQ/NE comparisons, we need the type of the operands + -- in order to do the comparison, which means we need the + -- bounds. + + when N_Op_Eq + | N_Op_Ne + => + declare + DT : Boolean := False; + begin + Check_Static_Type (Etype (Left_Opnd (N)), Empty, DT); + Check_Static_Type (Etype (Right_Opnd (N)), Empty, DT); + end; + + -- Likewise we need the sizes to compute how much to move in + -- an assignment. + + when N_Assignment_Statement => + declare + DT : Boolean := False; + begin + Check_Static_Type (Etype (Name (N)), Empty, DT); + Check_Static_Type (Etype (Expression (N)), Empty, DT); + end; + -- Record a subprogram. We record a subprogram body that acts -- as a spec. Otherwise we record a subprogram declaration, -- providing that it has a corresponding body we can get hold @@ -937,7 +1111,14 @@ package body Exp_Unst is return Skip; end if; - -- Otherwise record an uplevel reference + -- Pragmas and component declarations can be ignored + + when N_Component_Declaration + | N_Pragma + => + return Skip; + + -- Otherwise record an uplevel reference in a local identifier when others => if Nkind (N) in N_Has_Entity @@ -959,22 +1140,25 @@ package body Exp_Unst is -- references to global declarations. and then - (Ekind_In (Ent, E_Constant, E_Variable) + (Ekind_In (Ent, E_Constant, + E_Loop_Parameter, + E_Variable) - -- Formals are interesting, but not if being used as - -- mere names of parameters for name notation calls. + -- Formals are interesting, but not if being used + -- as mere names of parameters for name notation + -- calls. - or else - (Is_Formal (Ent) - and then not - (Nkind (Parent (N)) = N_Parameter_Association - and then Selector_Name (Parent (N)) = N)) + or else + (Is_Formal (Ent) + and then not + (Nkind (Parent (N)) = N_Parameter_Association + and then Selector_Name (Parent (N)) = N)) - -- Types other than known Is_Static types are - -- potentially interesting. + -- Types other than known Is_Static types are + -- potentially interesting. - or else (Is_Type (Ent) - and then not Is_Static_Type (Ent))) + or else + (Is_Type (Ent) and then not Is_Static_Type (Ent))) then -- Here we have a potentially interesting uplevel -- reference to examine. @@ -985,10 +1169,7 @@ package body Exp_Unst is begin Check_Static_Type (Ent, N, DT); - - if Is_Static_Type (Ent) then - return OK; - end if; + return OK; end; end if; @@ -996,9 +1177,24 @@ package body Exp_Unst is Callee := Enclosing_Subprogram (Ent); if Callee /= Caller - and then not Is_Static_Type (Ent) + and then (not Is_Static_Type (Ent) + or else Needs_Fat_Pointer (Ent)) then Note_Uplevel_Ref (Ent, N, Caller, Callee); + + -- Check the type of a formal parameter of the current + -- subprogram, whose formal type may be an uplevel + -- reference. + + elsif Is_Formal (Ent) + and then Scope (Ent) = Current_Subprogram + then + declare + DT : Boolean := False; + + begin + Check_Static_Type (Etype (Ent), Empty, DT); + end; end if; end if; end if; @@ -1124,13 +1320,32 @@ package body Exp_Unst is loop S := Enclosing_Subprogram (S); - -- if we are at the top level, as can happen with + -- If we are at the top level, as can happen with -- references to formals in aspects of nested subprogram - -- declarations, there are no further subprograms to - -- mark as requiring activation records. + -- declarations, there are no further subprograms to mark + -- as requiring activation records. exit when No (S); - Subps.Table (Subp_Index (S)).Declares_AREC := True; + + declare + SUBI : Subp_Entry renames Subps.Table (Subp_Index (S)); + begin + SUBI.Declares_AREC := True; + + -- If this entity was marked reachable because it is + -- in a task or protected type, there may not appear + -- to be any calls to it, which would normally adjust + -- the levels of the parent subprograms. So we need to + -- be sure that the uplevel reference of that entity + -- takes into account possible calls. + + if In_Synchronized_Unit (SUBF.Ent) + and then SUBT.Lev < SUBI.Uplevel_Ref + then + SUBI.Uplevel_Ref := SUBT.Lev; + end if; + end; + exit when S = URJ.Callee; end loop; @@ -1146,10 +1361,7 @@ package body Exp_Unst is and then Ekind (URJ.Ent) /= E_Discriminant then Set_Is_Uplevel_Referenced_Entity (URJ.Ent); - - if not Is_Type (URJ.Ent) then - Append_New_Elmt (URJ.Ent, SUBT.Uents); - end if; + Append_New_Elmt (URJ.Ent, SUBT.Uents); end if; -- And set uplevel indication for caller @@ -1180,13 +1392,6 @@ package body Exp_Unst is Decl : Node_Id; begin - -- Subprograms declared in tasks and protected types - -- are reachable and cannot be eliminated. - - if In_Synchronized_Unit (STJ.Ent) then - STJ.Reachable := True; - end if; - -- Subprogram is reachable, copy and reset index if STJ.Reachable then @@ -1212,7 +1417,8 @@ package body Exp_Unst is Write_Eol; end if; - -- Rewrite declaration and body to null statements + -- Rewrite declaration, body, and corresponding freeze node + -- to null statements. -- A subprogram instantiation does not have an explicit -- body. If unused, we could remove the corresponding @@ -1224,6 +1430,11 @@ package body Exp_Unst is if Present (Spec) then Decl := Parent (Declaration_Node (Spec)); Rewrite (Decl, Make_Null_Statement (Sloc (Decl))); + + if Present (Freeze_Node (Spec)) then + Rewrite (Freeze_Node (Spec), + Make_Null_Statement (Sloc (Decl))); + end if; end if; Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod))); @@ -1466,22 +1677,23 @@ package body Exp_Unst is -- Local declarations for one such subprogram declare - Loc : constant Source_Ptr := Sloc (STJ.Bod); + Loc : constant Source_Ptr := Sloc (STJ.Bod); + + Decls : constant List_Id := New_List; + -- List of new declarations we create + Clist : List_Id; Comp : Entity_Id; + Decl_Assign : Node_Id; + -- Assigment to set uplink, Empty if none + Decl_ARECnT : Node_Id; Decl_ARECnPT : Node_Id; Decl_ARECn : Node_Id; Decl_ARECnP : Node_Id; -- Declaration nodes for the AREC entities we build - Decl_Assign : Node_Id; - -- Assigment to set uplink, Empty if none - - Decls : List_Id; - -- List of new declarations we create - begin -- Build list of component declarations for ARECnT @@ -1512,8 +1724,9 @@ package body Exp_Unst is if Present (STJ.Uents) then declare - Elmt : Elmt_Id; - Uent : Entity_Id; + Elmt : Elmt_Id; + Ptr_Decl : Node_Id; + Uent : Entity_Id; Indx : Nat; -- 1's origin of index in list of elements. This is @@ -1533,21 +1746,42 @@ package body Exp_Unst is Set_Activation_Record_Component (Uent, Comp); - Append_To (Clist, - Make_Component_Declaration (Loc, - Defining_Identifier => Comp, - Component_Definition => - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Addr, Loc)))); + if Needs_Fat_Pointer (Uent) then + + -- Build corresponding access type + + Ptr_Decl := + Build_Access_Type_Decl + (Etype (Uent), STJ.Ent); + Append_To (Decls, Ptr_Decl); + + -- And use its type in the corresponding + -- component. + Append_To (Clist, + Make_Component_Declaration (Loc, + Defining_Identifier => Comp, + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of + (Defining_Identifier (Ptr_Decl), + Loc)))); + else + Append_To (Clist, + Make_Component_Declaration (Loc, + Defining_Identifier => Comp, + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Addr, Loc)))); + end if; Next_Elmt (Elmt); end loop; end; end if; -- Now we can insert the AREC declarations into the body - -- type ARECnT is record .. end record; -- pragma Suppress_Initialization (ARECnT); @@ -1562,7 +1796,7 @@ package body Exp_Unst is Component_List => Make_Component_List (Loc, Component_Items => Clist))); - Decls := New_List (Decl_ARECnT); + Append_To (Decls, Decl_ARECnT); -- type ARECnPT is access all ARECnT; @@ -1596,7 +1830,7 @@ package body Exp_Unst is New_Occurrence_Of (STJ.ARECnPT, Loc), Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (STJ.ARECn, Loc), Attribute_Name => Name_Access)); Append_To (Decls, Decl_ARECnP); @@ -1623,7 +1857,11 @@ package body Exp_Unst is Decl_Assign := Empty; end if; - Prepend_List_To (Declarations (STJ.Bod), Decls); + if No (Declarations (STJ.Bod)) then + Set_Declarations (STJ.Bod, Decls); + else + Prepend_List_To (Declarations (STJ.Bod), Decls); + end if; -- Analyze the newly inserted declarations. Note that we -- do not need to establish the whole scope stack, since @@ -1671,15 +1909,18 @@ package body Exp_Unst is Loc : constant Source_Ptr := Sloc (Ent); Dec : constant Node_Id := Declaration_Node (Ent); - Ins : Node_Id; - Asn : Node_Id; + + Asn : Node_Id; + Attr : Name_Id; + Ins : Node_Id; begin -- For parameters, we insert the assignment -- right after the declaration of ARECnP. - -- For all other entities, we insert - -- the assignment immediately after - -- the declaration of the entity. + -- For all other entities, we insert the + -- assignment immediately after the + -- declaration of the entity or after the + -- freeze node if present. -- Note: we don't need to mark the entity -- as being aliased, because the address @@ -1688,12 +1929,23 @@ package body Exp_Unst is if Is_Formal (Ent) then Ins := Decl_ARECnP; + + elsif Has_Delayed_Freeze (Ent) then + Ins := Freeze_Node (Ent); + else Ins := Dec; end if; -- Build and insert the assignment: -- ARECn.nam := nam'Address + -- or else 'Access for unconstrained array + + if Needs_Fat_Pointer (Ent) then + Attr := Name_Access; + else + Attr := Name_Address; + end if; Asn := Make_Assignment_Statement (Loc, @@ -1711,9 +1963,22 @@ package body Exp_Unst is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ent, Loc), - Attribute_Name => Name_Address)); + Attribute_Name => Attr)); + + -- If we have a loop parameter, we have + -- to insert before the first statement + -- of the loop. Ins points to the + -- N_Loop_Parameter_Specification. + + if Ekind (Ent) = E_Loop_Parameter then + Ins := + First + (Statements (Parent (Parent (Ins)))); + Insert_Before (Ins, Asn); - Insert_After (Ins, Asn); + else + Insert_After (Ins, Asn); + end if; -- Analyze the assignment statement. We do -- not need to establish the relevant scope @@ -1751,18 +2016,13 @@ package body Exp_Unst is begin -- Ignore type references, these are implicit references that do -- not need rewriting (e.g. the appearence in a conversion). - -- Also ignore if no reference was specified. + -- Also ignore if no reference was specified or if the rewriting + -- has already been done (this can happen if the N_Identifier + -- occurs more than one time in the tree). - if Is_Type (UPJ.Ent) or else No (UPJ.Ref) then - goto Continue; - end if; - - -- Also ignore uplevel references to bounds of types that come - -- from the original type reference. - - if Is_Entity_Name (UPJ.Ref) - and then Present (Entity (UPJ.Ref)) - and then Is_Type (Entity (UPJ.Ref)) + if No (UPJ.Ref) + or else not Is_Entity_Name (UPJ.Ref) + or else not Present (Entity (UPJ.Ref)) then goto Continue; end if; @@ -1776,7 +2036,7 @@ package body Exp_Unst is Typ : constant Entity_Id := Etype (UPJ.Ent); -- The type of the referenced entity - Atyp : constant Entity_Id := Get_Actual_Subtype (UPJ.Ref); + Atyp : Entity_Id; -- The actual subtype of the reference RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller); @@ -1796,6 +2056,12 @@ package body Exp_Unst is SI : SI_Type; begin + Atyp := Etype (UPJ.Ref); + + if Ekind (Atyp) /= E_Record_Subtype then + Atyp := Get_Actual_Subtype (UPJ.Ref); + end if; + -- Ignore if no ARECnF entity for enclosing subprogram which -- probably happens as a result of not properly treating -- instance bodies. To be examined ??? @@ -1867,17 +2133,30 @@ package body Exp_Unst is Comp := Activation_Record_Component (UPJ.Ent); pragma Assert (Present (Comp)); - -- Do the replacement + -- Do the replacement. If the component type is an access type, + -- this is an uplevel reference for an entity that requires a + -- fat pointer, so dereference the component. - Rewrite (UPJ.Ref, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Atyp, Loc), - Attribute_Name => Name_Deref, - Expressions => New_List ( - Make_Selected_Component (Loc, - Prefix => Pfx, - Selector_Name => - New_Occurrence_Of (Comp, Loc))))); + if Is_Access_Type (Etype (Comp)) then + Rewrite (UPJ.Ref, + Make_Explicit_Dereference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Pfx, + Selector_Name => + New_Occurrence_Of (Comp, Loc)))); + + else + Rewrite (UPJ.Ref, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Atyp, Loc), + Attribute_Name => Name_Deref, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Pfx, + Selector_Name => + New_Occurrence_Of (Comp, Loc))))); + end if; -- Analyze and resolve the new expression. We do not need to -- establish the relevant scope stack entries here, because we @@ -2058,6 +2337,13 @@ package body Exp_Unst is -- Tree visitor that search for outer level procedures with nested -- subprograms and invokes Unnest_Subprogram() + --------------- + -- Do_Search -- + --------------- + + procedure Do_Search is new Traverse_Proc (Search_Subprograms); + -- Subtree visitor instantiation + ------------------------ -- Search_Subprograms -- ------------------------ @@ -2079,22 +2365,22 @@ package body Exp_Unst is Unnest_Subprogram (Spec_Id, N); end if; end; + + -- The proper body of a stub may contain nested subprograms, and + -- therefore must be visited explicitly. Nested stubs are examined + -- recursively in Visit_Node. + + elsif Nkind (N) in N_Body_Stub then + Do_Search (Library_Unit (N)); end if; return OK; end Search_Subprograms; - --------------- - -- Do_Search -- - --------------- - - procedure Do_Search is new Traverse_Proc (Search_Subprograms); - -- Subtree visitor instantiation - -- Start of processing for Unnest_Subprograms begin - if not Opt.Unnest_Subprogram_Mode then + if not Opt.Unnest_Subprogram_Mode or not Opt.Expander_Active then return; end if; diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index 978e3d1..3b67a0d 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -562,6 +562,42 @@ package Exp_Unst is -- uplevel call, a subprogram at level 5 can call one at level 2 or even -- the outer level subprogram at level 1. + ------------------------------------- + -- Handling of unconstrained types -- + ------------------------------------- + + -- Objects whose nominal subtype is an unconstrained array type present + -- additional complications for translation into LLVM. The address + -- attribute of such objects points to the first component of the + -- array, and the bounds are found elsewhere, typically ahead of the + -- components. In many cases the bounds of an object are stored ahead + -- of the components and can be retrieved from it. However, if the + -- object is an expression (e.g. a slice) the bounds are not adjacent + -- and thus must be conveyed explicitly by means of a so-called + -- fat pointer. This leads to the following enhancements to the + -- handling of uplevel references described so far. This applies only + -- to uplevel references to unconstrained formals of enclosing + -- subprograms: + -- + -- a) Uplevel references are detected as before during the tree traversal + -- in Visit_Node. For reference to uplevel formals, we include those with + -- an unconstrained array type (e.g. String) even if such a type has + -- static bounds. + -- + -- b) references to unconstrained formals are recognized in the Subp + -- table by means of the predicate Needs_Fat_Pointer. + -- + -- c) When constructing the required activation record we also construct + -- a named access type whose designated type is the unconstrained array + -- type. The activation record of a subprogram that contains such an + -- uplevel reference includes a component of this access type. The + -- declaration for that access type is introduced and analyzed before + -- that of the activation record, so it appears in the subprogram that + -- has that formal. + -- + -- d) The uplevel reference is rewritten as an explicit dereference (.all) + -- of the corresponding pointer component. + -- ----------- -- Subps -- ----------- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 7573121..3bed508 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -682,16 +682,10 @@ package body Exp_Util is if Needs_Fin then - -- Certain run-time configurations and targets do not provide support - -- for controlled types. - - if Restriction_Active (No_Finalization) then - return; - -- Do nothing if the access type may never allocate / deallocate -- objects. - elsif No_Pool_Assigned (Ptr_Typ) then + if No_Pool_Assigned (Ptr_Typ) then return; end if; @@ -2313,7 +2307,7 @@ package body Exp_Util is Deriv_Typ := T; end if; - pragma Assert (Present (Deriv_Typ)); + pragma Assert (Present (Deriv_Typ)); -- Determine which rep item chain to use. Precedence is given to that -- of the parent type's partial view since it usually carries all the diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 3f0350a..9979cbf 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -5280,6 +5280,12 @@ package body Freeze is Result := No_List; goto Leave; + -- Do not freeze if we are preanalyzing without freezing + + elsif Inside_Preanalysis_Without_Freezing > 0 then + Result := No_List; + goto Leave; + elsif Ekind (E) = E_Generic_Package then Result := Freeze_Generic_Entities (E); goto Leave; @@ -6936,20 +6942,6 @@ package body Freeze is ----------------------- procedure Freeze_Expression (N : Node_Id) is - In_Spec_Exp : constant Boolean := In_Spec_Expression; - Typ : Entity_Id; - Nam : Entity_Id; - Desig_Typ : Entity_Id; - P : Node_Id; - Parent_P : Node_Id; - - Freeze_Outside : Boolean := False; - -- This flag is set true if the entity must be frozen outside the - -- current subprogram. This happens in the case of expander generated - -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do - -- not freeze all entities like other bodies, but which nevertheless - -- may reference entities that have to be frozen before the body and - -- obviously cannot be frozen inside the body. function Find_Aggregate_Component_Desig_Type return Entity_Id; -- If the expression is an array aggregate, the type of the component @@ -7038,6 +7030,30 @@ package body Freeze is end if; end In_Expanded_Body; + -- Local variables + + In_Spec_Exp : constant Boolean := In_Spec_Expression; + + Desig_Typ : Entity_Id; + Nam : Entity_Id; + P : Node_Id; + Parent_P : Node_Id; + Typ : Entity_Id; + + Freeze_Outside : Boolean := False; + -- This flag is set true if the entity must be frozen outside the + -- current subprogram. This happens in the case of expander generated + -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do + -- not freeze all entities like other bodies, but which nevertheless + -- may reference entities that have to be frozen before the body and + -- obviously cannot be frozen inside the body. + + Freeze_Outside_Subp : Entity_Id := Empty; + -- This entity is set if we are inside a subprogram body and the frozen + -- entity is defined in the enclosing scope of this subprogram. In such + -- case we must skip the subprogram body when climbing the parents chain + -- to locate the correct placement for the freezing node. + -- Start of processing for Freeze_Expression begin @@ -7081,8 +7097,8 @@ package body Freeze is if not Is_Frozen (Etype (N)) then Typ := Etype (N); - -- Base type may be an derived numeric type that is frozen at - -- the point of declaration, but first_subtype is still unfrozen. + -- Base type may be an derived numeric type that is frozen at the + -- point of declaration, but first_subtype is still unfrozen. elsif not Is_Frozen (First_Subtype (Etype (N))) then Typ := First_Subtype (Etype (N)); @@ -7138,8 +7154,7 @@ package body Freeze is if Is_Array_Type (Etype (N)) and then Is_Access_Type (Component_Type (Etype (N))) then - - -- Check whether aggregate includes allocators. + -- Check whether aggregate includes allocators Desig_Typ := Find_Aggregate_Component_Desig_Type; end if; @@ -7181,253 +7196,335 @@ package body Freeze is return; end if; - -- Examine the enclosing context by climbing the parent chain. The - -- traversal serves two purposes - to detect scenarios where freezeing - -- is not needed and to find the proper insertion point for the freeze - -- nodes. Although somewhat similar to Insert_Actions, this traversal - -- is freezing semantics-sensitive. Inserting freeze nodes blindly in - -- the tree may result in types being frozen too early. + -- Check if we are inside a subprogram body and the frozen entity is + -- defined in the enclosing scope of this subprogram. In such case we + -- must skip the subprogram when climbing the parents chain to locate + -- the correct placement for the freezing node. + + -- This is not needed for default expressions and other spec expressions + -- in generic units since the Move_Freeze_Nodes mechanism (sem_ch12.adb) + -- takes care of placing them at the proper place, after the generic + -- unit. + + if Present (Nam) + and then Scope (Nam) /= Current_Scope + and then not (In_Spec_Exp and then Inside_A_Generic) + then + declare + S : Entity_Id := Current_Scope; + + begin + while Present (S) + and then In_Same_Source_Unit (Nam, S) + loop + if Scope (S) = Scope (Nam) then + if Is_Subprogram (S) and then Has_Completion (S) then + Freeze_Outside_Subp := S; + end if; + + exit; + end if; + + S := Scope (S); + end loop; + end; + end if; + + -- Examine the enclosing context by climbing the parent chain + + -- If we identified that we must freeze the entity outside of a given + -- subprogram then we just climb up to that subprogram checking if some + -- enclosing node is marked as Must_Not_Freeze (since in such case we + -- must not freeze yet this entity). P := N; - loop - Parent_P := Parent (P); - -- If we don't have a parent, then we are not in a well-formed tree. - -- This is an unusual case, but there are some legitimate situations - -- in which this occurs, notably when the expressions in the range of - -- a type declaration are resolved. We simply ignore the freeze - -- request in this case. Is this right ??? + if Present (Freeze_Outside_Subp) then + loop + -- Do not freeze the current expression if another expression in + -- the chain of parents must not be frozen. - if No (Parent_P) then - return; - end if; + if Nkind (P) in N_Subexpr and then Must_Not_Freeze (P) then + return; + end if; - -- See if we have got to an appropriate point in the tree + Parent_P := Parent (P); - case Nkind (Parent_P) is + -- If we don't have a parent, then we are not in a well-formed + -- tree. This is an unusual case, but there are some legitimate + -- situations in which this occurs, notably when the expressions + -- in the range of a type declaration are resolved. We simply + -- ignore the freeze request in this case. - -- A special test for the exception of (RM 13.14(8)) for the case - -- of per-object expressions (RM 3.8(18)) occurring in component - -- definition or a discrete subtype definition. Note that we test - -- for a component declaration which includes both cases we are - -- interested in, and furthermore the tree does not have explicit - -- nodes for either of these two constructs. + if No (Parent_P) then + return; + end if; - when N_Component_Declaration => + exit when + Nkind (Parent_P) = N_Subprogram_Body + and then Unique_Defining_Entity (Parent_P) = + Freeze_Outside_Subp; - -- The case we want to test for here is an identifier that is - -- a per-object expression, this is either a discriminant that - -- appears in a context other than the component declaration - -- or it is a reference to the type of the enclosing construct. + P := Parent_P; + end loop; - -- For either of these cases, we skip the freezing + -- Otherwise the traversal serves two purposes - to detect scenarios + -- where freezeing is not needed and to find the proper insertion point + -- for the freeze nodes. Although somewhat similar to Insert_Actions, + -- this traversal is freezing semantics-sensitive. Inserting freeze + -- nodes blindly in the tree may result in types being frozen too early. - if not In_Spec_Expression - and then Nkind (N) = N_Identifier - and then (Present (Entity (N))) - then - -- We recognize the discriminant case by just looking for - -- a reference to a discriminant. It can only be one for - -- the enclosing construct. Skip freezing in this case. + else + loop + -- Do not freeze the current expression if another expression in + -- the chain of parents must not be frozen. - if Ekind (Entity (N)) = E_Discriminant then - return; + if Nkind (P) in N_Subexpr and then Must_Not_Freeze (P) then + return; + end if; - -- For the case of a reference to the enclosing record, - -- (or task or protected type), we look for a type that - -- matches the current scope. + Parent_P := Parent (P); - elsif Entity (N) = Current_Scope then - return; - end if; - end if; + -- If we don't have a parent, then we are not in a well-formed + -- tree. This is an unusual case, but there are some legitimate + -- situations in which this occurs, notably when the expressions + -- in the range of a type declaration are resolved. We simply + -- ignore the freeze request in this case. Is this right ??? - -- If we have an enumeration literal that appears as the choice in - -- the aggregate of an enumeration representation clause, then - -- freezing does not occur (RM 13.14(10)). + if No (Parent_P) then + return; + end if; - when N_Enumeration_Representation_Clause => + -- See if we have got to an appropriate point in the tree - -- The case we are looking for is an enumeration literal + case Nkind (Parent_P) is - if (Nkind (N) = N_Identifier or Nkind (N) = N_Character_Literal) - and then Is_Enumeration_Type (Etype (N)) - then - -- If enumeration literal appears directly as the choice, - -- do not freeze (this is the normal non-overloaded case) + -- A special test for the exception of (RM 13.14(8)) for the + -- case of per-object expressions (RM 3.8(18)) occurring in + -- component definition or a discrete subtype definition. Note + -- that we test for a component declaration which includes both + -- cases we are interested in, and furthermore the tree does + -- not have explicit nodes for either of these two constructs. + + when N_Component_Declaration => + + -- The case we want to test for here is an identifier that + -- is a per-object expression, this is either a discriminant + -- that appears in a context other than the component + -- declaration or it is a reference to the type of the + -- enclosing construct. + + -- For either of these cases, we skip the freezing - if Nkind (Parent (N)) = N_Component_Association - and then First (Choices (Parent (N))) = N + if not In_Spec_Expression + and then Nkind (N) = N_Identifier + and then (Present (Entity (N))) then - return; + -- We recognize the discriminant case by just looking for + -- a reference to a discriminant. It can only be one for + -- the enclosing construct. Skip freezing in this case. - -- If enumeration literal appears as the name of function - -- which is the choice, then also do not freeze. This - -- happens in the overloaded literal case, where the - -- enumeration literal is temporarily changed to a function - -- call for overloading analysis purposes. + if Ekind (Entity (N)) = E_Discriminant then + return; - elsif Nkind (Parent (N)) = N_Function_Call - and then - Nkind (Parent (Parent (N))) = N_Component_Association - and then - First (Choices (Parent (Parent (N)))) = Parent (N) + -- For the case of a reference to the enclosing record, + -- (or task or protected type), we look for a type that + -- matches the current scope. + + elsif Entity (N) = Current_Scope then + return; + end if; + end if; + + -- If we have an enumeration literal that appears as the choice + -- in the aggregate of an enumeration representation clause, + -- then freezing does not occur (RM 13.14(10)). + + when N_Enumeration_Representation_Clause => + + -- The case we are looking for is an enumeration literal + + if Nkind_In (N, N_Identifier, N_Character_Literal) + and then Is_Enumeration_Type (Etype (N)) then - return; + -- If enumeration literal appears directly as the choice, + -- do not freeze (this is the normal non-overloaded case) + + if Nkind (Parent (N)) = N_Component_Association + and then First (Choices (Parent (N))) = N + then + return; + + -- If enumeration literal appears as the name of function + -- which is the choice, then also do not freeze. This + -- happens in the overloaded literal case, where the + -- enumeration literal is temporarily changed to a + -- function call for overloading analysis purposes. + + elsif Nkind (Parent (N)) = N_Function_Call + and then Nkind (Parent (Parent (N))) = + N_Component_Association + and then First (Choices (Parent (Parent (N)))) = + Parent (N) + then + return; + end if; end if; - end if; - -- Normally if the parent is a handled sequence of statements, - -- then the current node must be a statement, and that is an - -- appropriate place to insert a freeze node. + -- Normally if the parent is a handled sequence of statements, + -- then the current node must be a statement, and that is an + -- appropriate place to insert a freeze node. - when N_Handled_Sequence_Of_Statements => + when N_Handled_Sequence_Of_Statements => - -- An exception occurs when the sequence of statements is for - -- an expander generated body that did not do the usual freeze - -- all operation. In this case we usually want to freeze - -- outside this body, not inside it, and we skip past the - -- subprogram body that we are inside. + -- An exception occurs when the sequence of statements is + -- for an expander generated body that did not do the usual + -- freeze all operation. In this case we usually want to + -- freeze outside this body, not inside it, and we skip + -- past the subprogram body that we are inside. - if In_Expanded_Body (Parent_P) then - declare - Subp : constant Node_Id := Parent (Parent_P); - Spec : Entity_Id; + if In_Expanded_Body (Parent_P) then + declare + Subp : constant Node_Id := Parent (Parent_P); + Spec : Entity_Id; - begin - -- Freeze the entity only when it is declared inside the - -- body of the expander generated procedure. This case - -- is recognized by the scope of the entity or its type, - -- which is either the spec for some enclosing body, or - -- (in the case of init_procs, for which there are no - -- separate specs) the current scope. - - if Nkind (Subp) = N_Subprogram_Body then - Spec := Corresponding_Spec (Subp); - - if (Present (Typ) and then Scope (Typ) = Spec) - or else - (Present (Nam) and then Scope (Nam) = Spec) - then - exit; + begin + -- Freeze the entity only when it is declared inside + -- the body of the expander generated procedure. + -- This case is recognized by the scope of the entity + -- or its type, which is either the spec for some + -- enclosing body, or (in the case of init_procs, + -- for which there are no separate specs) the current + -- scope. + + if Nkind (Subp) = N_Subprogram_Body then + Spec := Corresponding_Spec (Subp); + + if (Present (Typ) and then Scope (Typ) = Spec) + or else + (Present (Nam) and then Scope (Nam) = Spec) + then + exit; - elsif Present (Typ) - and then Scope (Typ) = Current_Scope - and then Defining_Entity (Subp) = Current_Scope - then - exit; + elsif Present (Typ) + and then Scope (Typ) = Current_Scope + and then Defining_Entity (Subp) = Current_Scope + then + exit; + end if; end if; - end if; - -- An expression function may act as a completion of - -- a function declaration. As such, it can reference - -- entities declared between the two views: + -- An expression function may act as a completion of + -- a function declaration. As such, it can reference + -- entities declared between the two views: - -- Hidden []; -- 1 - -- function F return ...; - -- private - -- function Hidden return ...; - -- function F return ... is (Hidden); -- 2 + -- Hidden []; -- 1 + -- function F return ...; + -- private + -- function Hidden return ...; + -- function F return ... is (Hidden); -- 2 - -- Refering to the example above, freezing the expression - -- of F (2) would place Hidden's freeze node (1) in the - -- wrong place. Avoid explicit freezing and let the usual - -- scenarios do the job - for example, reaching the end - -- of the private declarations, or a call to F. + -- Refering to the example above, freezing the + -- expression of F (2) would place Hidden's freeze + -- node (1) in the wrong place. Avoid explicit + -- freezing and let the usual scenarios do the job + -- (for example, reaching the end of the private + -- declarations, or a call to F.) - if Nkind (Original_Node (Subp)) = - N_Expression_Function - then - null; + if Nkind (Original_Node (Subp)) = N_Expression_Function + then + null; - -- Freeze outside the body + -- Freeze outside the body - else - Parent_P := Parent (Parent_P); - Freeze_Outside := True; - end if; - end; + else + Parent_P := Parent (Parent_P); + Freeze_Outside := True; + end if; + end; - -- Here if normal case where we are in handled statement - -- sequence and want to do the insertion right there. + -- Here if normal case where we are in handled statement + -- sequence and want to do the insertion right there. - else - exit; - end if; + else + exit; + end if; - -- If parent is a body or a spec or a block, then the current node - -- is a statement or declaration and we can insert the freeze node - -- before it. - - when N_Block_Statement - | N_Entry_Body - | N_Package_Body - | N_Package_Specification - | N_Protected_Body - | N_Subprogram_Body - | N_Task_Body - => - exit; - - -- The expander is allowed to define types in any statements list, - -- so any of the following parent nodes also mark a freezing point - -- if the actual node is in a list of statements or declarations. - - when N_Abortable_Part - | N_Accept_Alternative - | N_And_Then - | N_Case_Statement_Alternative - | N_Compilation_Unit_Aux - | N_Conditional_Entry_Call - | N_Delay_Alternative - | N_Elsif_Part - | N_Entry_Call_Alternative - | N_Exception_Handler - | N_Extended_Return_Statement - | N_Freeze_Entity - | N_If_Statement - | N_Or_Else - | N_Selective_Accept - | N_Triggering_Alternative - => - exit when Is_List_Member (P); - - -- Freeze nodes produced by an expression coming from the Actions - -- list of a N_Expression_With_Actions node must remain within the - -- Actions list. Inserting the freeze nodes further up the tree - -- may lead to use before declaration issues in the case of array - -- types. - - when N_Expression_With_Actions => - if Is_List_Member (P) - and then List_Containing (P) = Actions (Parent_P) - then + -- If parent is a body or a spec or a block, then the current + -- node is a statement or declaration and we can insert the + -- freeze node before it. + + when N_Block_Statement + | N_Entry_Body + | N_Package_Body + | N_Package_Specification + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body + => exit; - end if; - -- Note: N_Loop_Statement is a special case. A type that appears - -- in the source can never be frozen in a loop (this occurs only - -- because of a loop expanded by the expander), so we keep on - -- going. Otherwise we terminate the search. Same is true of any - -- entity which comes from source. (if they have predefined type, - -- that type does not appear to come from source, but the entity - -- should not be frozen here). + -- The expander is allowed to define types in any statements + -- list, so any of the following parent nodes also mark a + -- freezing point if the actual node is in a list of + -- statements or declarations. + + when N_Abortable_Part + | N_Accept_Alternative + | N_And_Then + | N_Case_Statement_Alternative + | N_Compilation_Unit_Aux + | N_Conditional_Entry_Call + | N_Delay_Alternative + | N_Elsif_Part + | N_Entry_Call_Alternative + | N_Exception_Handler + | N_Extended_Return_Statement + | N_Freeze_Entity + | N_If_Statement + | N_Or_Else + | N_Selective_Accept + | N_Triggering_Alternative + => + exit when Is_List_Member (P); + + -- Freeze nodes produced by an expression coming from the + -- Actions list of a N_Expression_With_Actions node must remain + -- within the Actions list. Inserting the freeze nodes further + -- up the tree may lead to use before declaration issues in the + -- case of array types. + + when N_Expression_With_Actions => + if Is_List_Member (P) + and then List_Containing (P) = Actions (Parent_P) + then + exit; + end if; - when N_Loop_Statement => - exit when not Comes_From_Source (Etype (N)) - and then (No (Nam) or else not Comes_From_Source (Nam)); + -- Note: N_Loop_Statement is a special case. A type that + -- appears in the source can never be frozen in a loop (this + -- occurs only because of a loop expanded by the expander), so + -- we keep on going. Otherwise we terminate the search. Same + -- is true of any entity which comes from source. (if they + -- have predefined type, that type does not appear to come + -- from source, but the entity should not be frozen here). - -- For all other cases, keep looking at parents + when N_Loop_Statement => + exit when not Comes_From_Source (Etype (N)) + and then (No (Nam) or else not Comes_From_Source (Nam)); - when others => - null; - end case; + -- For all other cases, keep looking at parents - -- We fall through the case if we did not yet find the proper - -- place in the free for inserting the freeze node, so climb. + when others => + null; + end case; - P := Parent_P; - end loop; + -- We fall through the case if we did not yet find the proper + -- place in the free for inserting the freeze node, so climb. + + P := Parent_P; + end loop; + end if; -- If the expression appears in a record or an initialization procedure, -- the freeze nodes are collected and attached to the current scope, to diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 730062b..1da6f9a 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -303,7 +303,7 @@ begin -- capture the values of the configuration switches (see Opt for further -- details). - Opt.Register_Opt_Config_Switches; + Register_Config_Switches; -- Check for file which contains No_Body pragma @@ -451,11 +451,6 @@ begin Check_Elaboration_Scenarios; - -- Remove any ignored Ghost code as it must not appear in the - -- executable. - - Remove_Ignored_Ghost_Code; - -- Examine all top level scenarios collected during analysis and -- resolution in order to diagnose conditional ABEs, even in the -- presence of serious errors. @@ -466,7 +461,9 @@ begin -- At this stage we can unnest subprogram bodies if required - Exp_Unst.Unnest_Subprograms (Cunit (Main_Unit)); + if Total_Errors_Detected = 0 then + Exp_Unst.Unnest_Subprograms (Cunit (Main_Unit)); + end if; -- List library units if requested @@ -481,6 +478,14 @@ begin Sem_Warn.Output_Unreferenced_Messages; Sem_Warn.Check_Unused_Withs; Sem_Warn.Output_Unused_Warnings_Off_Warnings; + + -- Remove any ignored Ghost code as it must not appear in the + -- executable. This action must be performed last because it + -- heavily alters the tree. + + if Operating_Mode = Generate_Code or else GNATprove_Mode then + Remove_Ignored_Ghost_Code; + end if; end if; end if; end; diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 9a52e6d..601f23a 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -613,7 +613,7 @@ OSCONS_EXTRACT=$(OSCONS_CC) $(GNATLIBCFLAGS_FOR_C) -S s-oscons-tmplt.i -$(MKDIR) ./bldtools/oscons $(RM) $(addprefix ./bldtools/oscons/,$(notdir $^)) $(CP) $^ ./bldtools/oscons - (cd ./bldtools/oscons ; gnatmake -q xoscons) + (cd ./bldtools/oscons ; $(GNATMAKE) -q xoscons) $(RTSDIR)/s-oscons.ads: ../stamp-gnatlib1-$(RTSDIR) s-oscons-tmplt.c gsocket.h ./bldtools/oscons/xoscons $(RM) $(RTSDIR)/s-oscons-tmplt.i $(RTSDIR)/s-oscons-tmplt.s diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index 23060c5..77e6bac 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -83,6 +83,12 @@ do { \ ((TREE_CODE (NODE) == INTEGER_TYPE || TREE_CODE (NODE) == ARRAY_TYPE) \ && TYPE_PACKED_ARRAY_TYPE_P (NODE)) +/* For FUNCTION_TYPE and METHOD_TYPE, nonzero if the function returns by + direct reference, i.e. the callee returns a pointer to a memory location + it has allocated and the caller only needs to dereference the pointer. */ +#define TYPE_RETURN_BY_DIRECT_REF_P(NODE) \ + TYPE_LANG_FLAG_0 (FUNC_OR_METHOD_CHECK (NODE)) + /* For INTEGER_TYPE, nonzero if this is a modular type with a modulus that is not equal to two to the power of its mode's size. */ #define TYPE_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (INTEGER_TYPE_CHECK (NODE)) @@ -91,10 +97,10 @@ do { \ an Ada array other than the first. */ #define TYPE_MULTI_ARRAY_P(NODE) TYPE_LANG_FLAG_1 (ARRAY_TYPE_CHECK (NODE)) -/* For FUNCTION_TYPE, nonzero if this denotes a function returning an - unconstrained array or record. */ +/* For FUNCTION_TYPE and METHOD_TYPE, nonzero if function returns an + unconstrained array or record type. */ #define TYPE_RETURN_UNCONSTRAINED_P(NODE) \ - TYPE_LANG_FLAG_1 (FUNCTION_TYPE_CHECK (NODE)) + TYPE_LANG_FLAG_1 (FUNC_OR_METHOD_CHECK (NODE)) /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this denotes a justified modular type (will only be true for RECORD_TYPE). */ @@ -152,12 +158,6 @@ do { \ #define TYPE_CONVENTION_FORTRAN_P(NODE) \ TYPE_LANG_FLAG_4 (ARRAY_TYPE_CHECK (NODE)) -/* For FUNCTION_TYPEs, nonzero if the function returns by direct reference, - i.e. the callee returns a pointer to a memory location it has allocated - and the caller only needs to dereference the pointer. */ -#define TYPE_RETURN_BY_DIRECT_REF_P(NODE) \ - TYPE_LANG_FLAG_4 (FUNCTION_TYPE_CHECK (NODE)) - /* For RECORD_TYPE, UNION_TYPE and ENUMERAL_TYPE, nonzero if this is a dummy type, made to correspond to a private or incomplete type. */ #define TYPE_DUMMY_P(NODE) \ @@ -186,6 +186,9 @@ do { \ /* True for a dummy type if TYPE appears in a profile. */ #define TYPE_DUMMY_IN_PROFILE_P(NODE) TYPE_LANG_FLAG_6 (NODE) +/* True if objects of this type are guaranteed to be properly aligned. */ +#define TYPE_ALIGN_OK(NODE) TYPE_LANG_FLAG_7 (NODE) + /* True for types that implement a packed array and for original packed array types. */ #define TYPE_IMPL_PACKED_ARRAY_P(NODE) \ @@ -199,9 +202,6 @@ do { \ alignment value the type ought to have. */ #define TYPE_MAX_ALIGN(NODE) (TYPE_PRECISION (RECORD_OR_UNION_CHECK (NODE))) -/* True if objects of tagged types are guaranteed to be properly aligned. */ -#define TYPE_ALIGN_OK(NODE) TYPE_LANG_FLAG_7 (NODE) - /* For an UNCONSTRAINED_ARRAY_TYPE, this is the record containing both the template and the object. @@ -228,17 +228,16 @@ do { \ #define TYPE_GCC_MAX_VALUE(NODE) \ (TYPE_MAX_VALUE_RAW (NUMERICAL_TYPE_CHECK (NODE))) -/* For a FUNCTION_TYPE, if the subprogram has parameters passed by copy in/ - copy out, this is the list of nodes used to specify the return values of - the out (or in out) parameters that are passed by copy in/copy out. For - a full description of the copy in/copy out parameter passing mechanism - refer to the routine gnat_to_gnu_entity. */ -#define TYPE_CI_CO_LIST(NODE) TYPE_LANG_SLOT_1 (FUNCTION_TYPE_CHECK (NODE)) +/* For a FUNCTION_TYPE and METHOD_TYPE, if the function has parameters passed + by copy in/copy out, this is the list of nodes used to specify the return + values of these parameters. For a full description of the copy in/copy out + parameter passing mechanism refer to the routine gnat_to_gnu_entity. */ +#define TYPE_CI_CO_LIST(NODE) TYPE_LANG_SLOT_1 (FUNC_OR_METHOD_CHECK (NODE)) /* For an ARRAY_TYPE with variable size, this is the padding type built for the array type when it is itself the component type of another array. */ #define TYPE_PADDING_FOR_COMPONENT(NODE) \ - (TYPE_LANG_SLOT_1 (ARRAY_TYPE_CHECK (NODE))) + TYPE_LANG_SLOT_1 (ARRAY_TYPE_CHECK (NODE)) /* For a VECTOR_TYPE, this is the representative array type. */ #define TYPE_REPRESENTATIVE_ARRAY(NODE) \ diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index c482884..b1dc379 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -52,23 +52,19 @@ #include "ada-tree.h" #include "gigi.h" -/* "stdcall" and "thiscall" conventions should be processed in a specific way - on 32-bit x86/Windows only. The macros below are helpers to avoid having - to check for a Windows specific attribute throughout this unit. */ +/* The "stdcall" convention is really supported on 32-bit x86/Windows only. + The following macro is a helper to avoid having to check for a Windows + specific attribute throughout this unit. */ #if TARGET_DLLIMPORT_DECL_ATTRIBUTES #ifdef TARGET_64BIT #define Has_Stdcall_Convention(E) \ (!TARGET_64BIT && Convention (E) == Convention_Stdcall) -#define Has_Thiscall_Convention(E) \ - (!TARGET_64BIT && is_cplusplus_method (E)) #else #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall) -#define Has_Thiscall_Convention(E) (is_cplusplus_method (E)) #endif #else #define Has_Stdcall_Convention(E) 0 -#define Has_Thiscall_Convention(E) 0 #endif #define STDCALL_PREFIX "_imp__" @@ -123,6 +119,9 @@ typedef struct variant_desc_d { /* The type of the variant after transformation. */ tree new_type; + + /* The auxiliary data. */ + tree aux; } variant_desc; @@ -207,7 +206,6 @@ static tree gnat_to_gnu_subprog_type (Entity_Id, bool, bool, tree *); static int adjust_packed (tree, tree, int); static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool); static tree gnu_ext_name_for_subprog (Entity_Id, tree); -static tree change_qualified_type (tree, int); static void set_nonaliased_component_on_array_type (tree); static void set_reverse_storage_order_on_array_type (tree); static bool same_discriminant_p (Entity_Id, Entity_Id); @@ -271,7 +269,9 @@ static bool intrin_profiles_compatible_p (intrin_binding_t *); tree gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) { - /* Contains the kind of the input GNAT node. */ + /* The construct that declared the entity. */ + const Node_Id gnat_decl = Declaration_Node (gnat_entity); + /* The kind of the entity. */ const Entity_Kind kind = Ekind (gnat_entity); /* True if this is a type. */ const bool is_type = IN (kind, Type_Kind); @@ -428,11 +428,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) || Is_Public (gnat_entity)); /* Get the name of the entity and set up the line number and filename of - the original definition for use in any decl we make. Make sure we do not - inherit another source location. */ + the original definition for use in any decl we make. Make sure we do + not inherit another source location. */ gnu_entity_name = get_entity_name (gnat_entity); - if (Sloc (gnat_entity) != No_Location - && !renaming_from_instantiation_p (gnat_entity)) + if (!renaming_from_instantiation_p (gnat_entity)) Sloc_to_locus (Sloc (gnat_entity), &input_location); /* For cases when we are not defining (i.e., we are referencing from @@ -577,7 +576,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (definition && !gnu_expr && No (Address_Clause (gnat_entity)) - && !No_Initialization (Declaration_Node (gnat_entity)) + && !No_Initialization (gnat_decl) && No (Renamed_Object (gnat_entity))) { gnu_decl = error_mark_node; @@ -600,14 +599,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If we have a constant that we are not defining, get the expression it was defined to represent. This is necessary to avoid generating dumb elaboration code in simple cases, but we may throw it away later if it - is not a constant. But do not retrieve it if it is an allocator since + is not a constant. But do not do it for dispatch tables because they + are only referenced indirectly and we need to have a consistent view + of the exported and of the imported declarations of the tables from + external units for them to be properly merged in LTO mode. Moreover + simply do not retrieve the expression it if it is an allocator since the designated type might still be dummy at this point. Note that we invoke gnat_to_gnu_external and not gnat_to_gnu because the expression may contain N_Expression_With_Actions nodes and thus declarations of objects from other units that we need to discard. */ if (!definition - && !No_Initialization (Declaration_Node (gnat_entity)) - && Present (gnat_temp = Expression (Declaration_Node (gnat_entity))) + && !No_Initialization (gnat_decl) + && !Is_Dispatch_Table_Entity (gnat_entity) + && Present (gnat_temp = Expression (gnat_decl)) && Nkind (gnat_temp) != N_Allocator && (!type_annotate_only || Compile_Time_Known_Value (gnat_temp))) gnu_expr = gnat_to_gnu_external (gnat_temp); @@ -628,9 +632,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && !(kind == E_Variable && Present (Linker_Section_Pragma (gnat_entity))) && !Treat_As_Volatile (gnat_entity) - && (((Nkind (Declaration_Node (gnat_entity)) - == N_Object_Declaration) - && Present (Expression (Declaration_Node (gnat_entity)))) + && (((Nkind (gnat_decl) == N_Object_Declaration) + && Present (Expression (gnat_decl))) || Present (Renamed_Object (gnat_entity)) || imported_p)); bool inner_const_flag = const_flag; @@ -644,7 +647,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) bool used_by_ref = false; tree gnu_ext_name = NULL_TREE; tree renamed_obj = NULL_TREE; - tree gnu_object_size; + tree gnu_ada_size = NULL_TREE; /* We need to translate the renamed object even though we are only referencing the renaming. But it may contain a call for which @@ -749,8 +752,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) { if (gnu_expr && kind == E_Constant) { - tree size = TYPE_SIZE (TREE_TYPE (gnu_expr)); - if (CONTAINS_PLACEHOLDER_P (size)) + gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr)); + gnu_ada_size = TYPE_ADA_SIZE (TREE_TYPE (gnu_expr)); + if (CONTAINS_PLACEHOLDER_P (gnu_size)) { /* If the initializing expression is itself a constant, despite having a nominal type with self-referential @@ -762,27 +766,38 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0)) || DECL_READONLY_ONCE_ELAB (TREE_OPERAND (gnu_expr, 0)))) - gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0)); + { + gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0)); + gnu_ada_size = gnu_size; + } else - gnu_size - = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr); + { + gnu_size + = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, + gnu_expr); + gnu_ada_size + = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_ada_size, + gnu_expr); + } } - else - gnu_size = size; } /* We may have no GNU_EXPR because No_Initialization is set even though there's an Expression. */ else if (kind == E_Constant - && (Nkind (Declaration_Node (gnat_entity)) - == N_Object_Declaration) - && Present (Expression (Declaration_Node (gnat_entity)))) - gnu_size - = TYPE_SIZE (gnat_to_gnu_type - (Etype - (Expression (Declaration_Node (gnat_entity))))); + && Nkind (gnat_decl) == N_Object_Declaration + && Present (Expression (gnat_decl))) + { + tree gnu_expr_type + = gnat_to_gnu_type (Etype (Expression (gnat_decl))); + gnu_size = TYPE_SIZE (gnu_expr_type); + gnu_ada_size = TYPE_ADA_SIZE (gnu_expr_type); + } else { gnu_size = max_size (TYPE_SIZE (gnu_type), true); + /* We can be called on unconstrained arrays in this mode. */ + if (!type_annotate_only) + gnu_ada_size = max_size (TYPE_ADA_SIZE (gnu_type), true); mutable_p = true; } @@ -898,7 +913,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Make a new type with the desired size and alignment, if needed. But do not take into account alignment promotions to compute the size of the object. */ - gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type); + tree gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type); if (gnu_size || align > 0) { tree orig_type = gnu_type; @@ -906,6 +921,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, false, false, definition, true); + /* If the nominal subtype of the object is unconstrained and its + size is not fixed, compute the Ada size from the Ada size of + the subtype and/or the expression; this will make it possible + for gnat_type_max_size to easily compute a maximum size. */ + if (gnu_ada_size && gnu_size && !TREE_CONSTANT (gnu_size)) + SET_TYPE_ADA_SIZE (gnu_type, gnu_ada_size); + /* If a padding record was made, declare it now since it will never be declared otherwise. This is necessary to ensure that its subtrees are properly marked. */ @@ -947,8 +969,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) function call is a constant object. Therefore, it can be the inner object of a constant renaming and the renaming must be fully instantiated, i.e. it cannot be a reference to (part of) - an existing object. And treat other rvalues (addresses, null - expressions, constructors and literals) the same way. */ + an existing object. And treat other rvalues the same way. */ tree inner = gnu_expr; while (handled_component_p (inner) || CONVERT_EXPR_P (inner)) inner = TREE_OPERAND (inner, 0); @@ -959,11 +980,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) inner = TREE_OPERAND (inner, 1); if ((TREE_CODE (inner) == CALL_EXPR && !call_is_atomic_load (inner)) - || TREE_CODE (inner) == ADDR_EXPR - || TREE_CODE (inner) == NULL_EXPR - || TREE_CODE (inner) == PLUS_EXPR || TREE_CODE (inner) == CONSTRUCTOR || CONSTANT_CLASS_P (inner) + || COMPARISON_CLASS_P (inner) + || BINARY_CLASS_P (inner) + || EXPRESSION_CLASS_P (inner) /* We need to detect the case where a temporary is created to hold the return value, since we cannot safely rename it at top level as it lives only in the elaboration routine. */ @@ -985,7 +1006,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) underlying object lives only in the elaboration routine. */ || (TREE_CODE (inner) == INDIRECT_REF && (inner - = remove_conversions (TREE_OPERAND (inner, 0), true)) + = remove_conversions (TREE_OPERAND (inner, 0), true)) && TREE_CODE (inner) == VAR_DECL && DECL_RETURN_VALUE_P (inner))) ; @@ -1927,7 +1948,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* We will output additional debug info manually below. */ finish_record_type (gnu_type, gnu_field, 2, false); - compute_record_mode (gnu_type); TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1; if (debug_info_p) @@ -2055,11 +2075,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) { gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type)); TYPE_NAME (gnu_fat_type) = NULL_TREE; - /* Save the contents of the dummy type for update_pointer_to. */ - TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type); gnu_ptr_template = - TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat_type))); + TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_fat_type))); gnu_template_type = TREE_TYPE (gnu_ptr_template); + + /* Save the contents of the dummy type for update_pointer_to. */ + TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type); + TYPE_FIELDS (TYPE_POINTER_TO (gnu_type)) + = copy_node (TYPE_FIELDS (gnu_fat_type)); + DECL_CHAIN (TYPE_FIELDS (TYPE_POINTER_TO (gnu_type))) + = copy_node (DECL_CHAIN (TYPE_FIELDS (gnu_fat_type))); } else { @@ -2080,29 +2105,39 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Build the fat pointer type. Use a "void *" object instead of a pointer to the array type since we don't have the array type - yet (it will reference the fat pointer via the bounds). */ - tem - = create_field_decl (get_identifier ("P_ARRAY"), ptr_type_node, - gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0); - DECL_CHAIN (tem) - = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template, - gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0); - + yet (it will reference the fat pointer via the bounds). Note + that we reuse the existing fields of a dummy type because for: + + type Arr is array (Positive range <>) of Element_Type; + type Array_Ref is access Arr; + Var : Array_Ref := Null; + + in a declarative part, Arr will be frozen only after Var, which + means that the fields used in the CONSTRUCTOR built for Null are + those of the dummy type, which in turn means that COMPONENT_REFs + of Var may be built with these fields. Now if COMPONENT_REFs of + Var are also built later with the fields of the final type, the + aliasing machinery may consider that the accesses are distinct + if the FIELD_DECLs are distinct as objects. */ if (COMPLETE_TYPE_P (gnu_fat_type)) { - /* We are going to lay it out again so reset the alias set. */ - alias_set_type alias_set = TYPE_ALIAS_SET (gnu_fat_type); - TYPE_ALIAS_SET (gnu_fat_type) = -1; - finish_fat_pointer_type (gnu_fat_type, tem); - TYPE_ALIAS_SET (gnu_fat_type) = alias_set; + tem = TYPE_FIELDS (gnu_fat_type); + TREE_TYPE (tem) = ptr_type_node; + TREE_TYPE (DECL_CHAIN (tem)) = gnu_ptr_template; + TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 0; for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t)) - { - TYPE_FIELDS (t) = tem; - SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type); - } + SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type); } else { + tem + = create_field_decl (get_identifier ("P_ARRAY"), + ptr_type_node, gnu_fat_type, + NULL_TREE, NULL_TREE, 0, 0); + DECL_CHAIN (tem) + = create_field_decl (get_identifier ("P_BOUNDS"), + gnu_ptr_template, gnu_fat_type, + NULL_TREE, NULL_TREE, 0, 0); finish_fat_pointer_type (gnu_fat_type, tem); SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type); } @@ -2921,23 +2956,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) the tree. */ case E_Record_Type: - if (Has_Complex_Representation (gnat_entity)) - { - gnu_type - = build_complex_type - (get_unpadded_type - (Etype (Defining_Entity - (First (Component_Items - (Component_List - (Type_Definition - (Declaration_Node (gnat_entity))))))))); + { + Node_Id record_definition = Type_Definition (gnat_decl); - break; - } + if (Has_Complex_Representation (gnat_entity)) + { + const Node_Id first_component + = First (Component_Items (Component_List (record_definition))); + tree gnu_component_type + = get_unpadded_type (Etype (Defining_Entity (first_component))); + gnu_type = build_complex_type (gnu_component_type); + break; + } - { - Node_Id full_definition = Declaration_Node (gnat_entity); - Node_Id record_definition = Type_Definition (full_definition); Node_Id gnat_constr; Entity_Id gnat_field, gnat_parent_type; tree gnu_field, gnu_field_list = NULL_TREE; @@ -3389,20 +3420,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) break; } - /* If this is a record subtype associated with a dispatch table, - strip the suffix. This is necessary to make sure 2 different - subtypes associated with the imported and exported views of a - dispatch table are properly merged in LTO mode. */ - if (Is_Dispatch_Table_Entity (gnat_entity)) - { - char *p; - Get_Encoded_Name (gnat_entity); - p = strchr (Name_Buffer, '_'); - gcc_assert (p); - strcpy (p+2, "dtS"); - gnu_entity_name = get_identifier (Name_Buffer); - } - /* When the subtype has discriminants and these discriminants affect the initial shape it has inherited, factor them in. But for an Unchecked_Union (it must be an Itype), just return the type. */ @@ -3961,11 +3978,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) (&attr_list, ATTR_MACHINE_ATTRIBUTE, get_identifier ("stdcall"), NULL_TREE, gnat_entity); - else if (Has_Thiscall_Convention (gnat_entity)) - prepend_one_attribute - (&attr_list, ATTR_MACHINE_ATTRIBUTE, - get_identifier ("thiscall"), NULL_TREE, - gnat_entity); /* If we should request stack realignment for a foreign convention subprogram, do so. Note that this applies to task entry points @@ -4439,7 +4451,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If this is not an unconstrained array type, set some flags. */ if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE) { - /* Tell the middle-end that objects of tagged types are guaranteed to + /* Record the property that objects of tagged types are guaranteed to be properly aligned. This is necessary because conversions to the class-wide type are translated into conversions to the root type, which can be less aligned than some of its derived types. */ @@ -4819,11 +4831,12 @@ get_unpadded_type (Entity_Id gnat_entity) /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is a C++ imported method or equivalent. - We use the predicate on 32-bit x86/Windows to find out whether we need to - use the "thiscall" calling convention for GNAT_ENTITY. This convention is - used for C++ methods (functions with METHOD_TYPE) by the back-end. */ + We use the predicate to find out whether we need to use METHOD_TYPE instead + of FUNCTION_TYPE for GNAT_ENTITY for the sake compatibility with C++. This + in turn determines whether the "thiscall" calling convention is used by the + back-end for GNAT_ENTITY on 32-bit x86/Windows. */ -bool +static bool is_cplusplus_method (Entity_Id gnat_entity) { /* A constructor is a method on the C++ side. We deal with it now because @@ -5221,7 +5234,6 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first, && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type))) gnu_param_type = TREE_TYPE (gnu_param_type); - by_component_ptr = true; gnu_param_type = TREE_TYPE (gnu_param_type); if (ro_param) @@ -5229,6 +5241,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first, = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST); gnu_param_type = build_pointer_type (gnu_param_type); + by_component_ptr = true; } /* Fat pointers are passed as thin pointers for foreign conventions. */ @@ -5236,6 +5249,14 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first, gnu_param_type = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0); + /* Use a pointer type for the "this" pointer of C++ constructors. */ + else if (Chars (gnat_param) == Name_uInit && Is_Constructor (gnat_subprog)) + { + gcc_assert (mech == By_Reference); + gnu_param_type = build_pointer_type (gnu_param_type); + by_ref = true; + } + /* If we were requested or muss pass by reference, do so. If we were requested to pass by copy, do so. Otherwise, for foreign conventions, pass In Out or Out parameters @@ -5535,6 +5556,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, bool debug_info_p, tree *param_list) { const Entity_Kind kind = Ekind (gnat_subprog); + const bool method_p = is_cplusplus_method (gnat_subprog); Entity_Id gnat_return_type = Etype (gnat_subprog); Entity_Id gnat_param; tree gnu_type = present_gnu_tree (gnat_subprog) @@ -5554,14 +5576,15 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, /* Fields in return type of procedure with copy-in copy-out parameters. */ tree gnu_field_list = NULL_TREE; /* The semantics of "pure" in Ada essentially matches that of "const" - in the back-end. In particular, both properties are orthogonal to - the "nothrow" property if the EH circuitry is explicit in the - internal representation of the back-end. If we are to completely + or "pure" in GCC. In particular, both properties are orthogonal + to the "nothrow" property if the EH circuitry is explicit in the + internal representation of the middle-end. If we are to completely hide the EH circuitry from it, we need to declare that calls to pure Ada subprograms that can throw have side effects since they can - trigger an "abnormal" transfer of control flow; thus they can be - neither "const" nor "pure" in the back-end sense. */ + trigger an "abnormal" transfer of control flow; therefore, they can + be neither "const" nor "pure" in the GCC sense. */ bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_subprog)); + bool pure_flag = false; bool return_by_direct_ref_p = false; bool return_by_invisi_ref_p = false; bool return_unconstrained_p = false; @@ -5575,7 +5598,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, gnu_return_type = void_type_node; else if (gnu_type - && TREE_CODE (gnu_type) == FUNCTION_TYPE + && FUNC_OR_METHOD_TYPE_P (gnu_type) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_type))) { gnu_return_type = TREE_TYPE (gnu_type); @@ -5720,7 +5743,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, Similarly, if the function returns an unconstrained type, then the function will allocate the return value on the secondary stack and thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */ - if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p) + if (VOID_TYPE_P (gnu_return_type) || return_unconstrained_p) const_flag = false; /* Loop over the parameters and get their associated GCC tree. While doing @@ -5839,16 +5862,23 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, { gnu_param_type_list = tree_cons (NULL_TREE, gnu_param_type, gnu_param_type_list); - gnu_param_list = chainon (gnu_param, gnu_param_list); + DECL_CHAIN (gnu_param) = gnu_param_list; + gnu_param_list = gnu_param; save_gnu_tree (gnat_param, gnu_param, false); - /* If a parameter is a pointer, a function may modify memory through - it and thus shouldn't be considered a const function. Also, the - memory may be modified between two calls, so they can't be CSE'ed. - The latter case also handles by-ref parameters. */ - if (POINTER_TYPE_P (gnu_param_type) - || TYPE_IS_FAT_POINTER_P (gnu_param_type)) - const_flag = false; + /* A pure function in the Ada sense which takes an access parameter + may modify memory through it and thus need be considered neither + const nor pure in the GCC sense. Likewise it if takes a by-ref + In Out or Out parameter. But if it takes a by-ref In parameter, + then it may only read memory through it and can be considered + pure in the GCC sense. */ + if ((const_flag || pure_flag) + && (POINTER_TYPE_P (gnu_param_type) + || TYPE_IS_FAT_POINTER_P (gnu_param_type))) + { + const_flag = false; + pure_flag = DECL_POINTS_TO_READONLY_P (gnu_param); + } } /* If the parameter uses the copy-in copy-out mechanism, allocate a field @@ -5946,18 +5976,37 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, /* The lists have been built in reverse. */ gnu_param_type_list = nreverse (gnu_param_type_list); gnu_param_type_list = chainon (gnu_param_type_list, void_list_node); - *param_list = nreverse (gnu_param_list); + gnu_param_list = nreverse (gnu_param_list); gnu_cico_list = nreverse (gnu_cico_list); + /* Turn imported C++ constructors into their callable form as done in the + front-end, i.e. add the "this" pointer and void the return type. */ + if (method_p + && Is_Constructor (gnat_subprog) + && !VOID_TYPE_P (gnu_return_type)) + { + tree gnu_param_type + = build_pointer_type (gnat_to_gnu_profile_type (gnat_return_type)); + tree gnu_param_name = get_identifier (Get_Name_String (Name_uInit)); + tree gnu_param + = build_decl (input_location, PARM_DECL, gnu_param_name, + gnu_param_type); + gnu_param_type_list + = tree_cons (NULL_TREE, gnu_param_type, gnu_param_type_list); + DECL_CHAIN (gnu_param) = gnu_param_list; + gnu_param_list = gnu_param; + gnu_return_type = void_type_node; + } + /* If the profile is incomplete, we only set the (temporary) return and parameter types; otherwise, we build the full type. In either case, we reuse an already existing GCC tree that we built previously here. */ if (incomplete_profile_p) { - if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE) + if (gnu_type && FUNC_OR_METHOD_TYPE_P (gnu_type)) ; else - gnu_type = make_node (FUNCTION_TYPE); + gnu_type = make_node (method_p ? METHOD_TYPE : FUNCTION_TYPE); TREE_TYPE (gnu_type) = gnu_return_type; TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list; TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p; @@ -5966,10 +6015,16 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, } else { - if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE) + if (gnu_type && FUNC_OR_METHOD_TYPE_P (gnu_type)) { TREE_TYPE (gnu_type) = gnu_return_type; TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list; + if (method_p) + { + tree gnu_basetype = TREE_TYPE (TREE_VALUE (gnu_param_type_list)); + TYPE_METHOD_BASETYPE (gnu_type) + = TYPE_MAIN_VARIANT (gnu_basetype); + } TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list; TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p; TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p; @@ -5979,8 +6034,16 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, } else { - gnu_type - = build_function_type (gnu_return_type, gnu_param_type_list); + if (method_p) + { + tree gnu_basetype = TREE_TYPE (TREE_VALUE (gnu_param_type_list)); + gnu_type + = build_method_type_directly (gnu_basetype, gnu_return_type, + TREE_CHAIN (gnu_param_type_list)); + } + else + gnu_type + = build_function_type (gnu_return_type, gnu_param_type_list); /* GNU_TYPE may be shared since GCC hashes types. Unshare it if it has a different TYPE_CI_CO_LIST or flags. */ @@ -6000,6 +6063,9 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, if (const_flag) gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST); + if (pure_flag) + gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_RESTRICT); + if (No_Return (gnat_subprog)) gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE); @@ -6038,6 +6104,8 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, } } + *param_list = gnu_param_list; + return gnu_type; } @@ -6057,19 +6125,6 @@ gnu_ext_name_for_subprog (Entity_Id gnat_subprog, tree gnu_entity_name) return gnu_ext_name; } -/* Like build_qualified_type, but TYPE_QUALS is added to the existing - qualifiers on TYPE. */ - -static tree -change_qualified_type (tree type, int type_quals) -{ - /* Qualifiers must be put on the associated array type. */ - if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) - return type; - - return build_qualified_type (type, TYPE_QUALS (type) | type_quals); -} - /* Set TYPE_NONALIASED_COMPONENT on an array type built by means of build_nonshared_array_type. */ @@ -6650,65 +6705,44 @@ elaborate_reference (tree ref, Entity_Id gnat_entity, bool definition, the value passed against the list of choices. */ static tree -choices_to_gnu (tree operand, Node_Id choices) +choices_to_gnu (tree gnu_operand, Node_Id gnat_choices) { - Node_Id choice; - Node_Id gnat_temp; - tree result = boolean_false_node; - tree this_test, low = 0, high = 0, single = 0; + tree gnu_result = boolean_false_node, gnu_type; - for (choice = First (choices); Present (choice); choice = Next (choice)) + gnu_operand = maybe_character_value (gnu_operand); + gnu_type = TREE_TYPE (gnu_operand); + + for (Node_Id gnat_choice = First (gnat_choices); + Present (gnat_choice); + gnat_choice = Next (gnat_choice)) { - switch (Nkind (choice)) + tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; + tree gnu_test; + + switch (Nkind (gnat_choice)) { case N_Range: - low = gnat_to_gnu (Low_Bound (choice)); - high = gnat_to_gnu (High_Bound (choice)); - - this_test - = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, - build_binary_op (GE_EXPR, boolean_type_node, - operand, low, true), - build_binary_op (LE_EXPR, boolean_type_node, - operand, high, true), - true); - + gnu_low = gnat_to_gnu (Low_Bound (gnat_choice)); + gnu_high = gnat_to_gnu (High_Bound (gnat_choice)); break; case N_Subtype_Indication: - gnat_temp = Range_Expression (Constraint (choice)); - low = gnat_to_gnu (Low_Bound (gnat_temp)); - high = gnat_to_gnu (High_Bound (gnat_temp)); - - this_test - = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, - build_binary_op (GE_EXPR, boolean_type_node, - operand, low, true), - build_binary_op (LE_EXPR, boolean_type_node, - operand, high, true), - true); + gnu_low = gnat_to_gnu (Low_Bound (Range_Expression + (Constraint (gnat_choice)))); + gnu_high = gnat_to_gnu (High_Bound (Range_Expression + (Constraint (gnat_choice)))); break; case N_Identifier: case N_Expanded_Name: - /* This represents either a subtype range, an enumeration - literal, or a constant Ekind says which. If an enumeration - literal or constant, fall through to the next case. */ - if (Ekind (Entity (choice)) != E_Enumeration_Literal - && Ekind (Entity (choice)) != E_Constant) + /* This represents either a subtype range or a static value of + some kind; Ekind says which. */ + if (Is_Type (Entity (gnat_choice))) { - tree type = gnat_to_gnu_type (Entity (choice)); - - low = TYPE_MIN_VALUE (type); - high = TYPE_MAX_VALUE (type); - - this_test - = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, - build_binary_op (GE_EXPR, boolean_type_node, - operand, low, true), - build_binary_op (LE_EXPR, boolean_type_node, - operand, high, true), - true); + tree gnu_type = get_unpadded_type (Entity (gnat_choice)); + + gnu_low = TYPE_MIN_VALUE (gnu_type); + gnu_high = TYPE_MAX_VALUE (gnu_type); break; } @@ -6716,27 +6750,49 @@ choices_to_gnu (tree operand, Node_Id choices) case N_Character_Literal: case N_Integer_Literal: - single = gnat_to_gnu (choice); - this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand, - single, true); + gnu_low = gnat_to_gnu (gnat_choice); break; case N_Others_Choice: - this_test = boolean_true_node; break; default: gcc_unreachable (); } - if (result == boolean_false_node) - result = this_test; + /* Everything should be folded into constants at this point. */ + gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST); + gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST); + + if (gnu_low && TREE_TYPE (gnu_low) != gnu_type) + gnu_low = convert (gnu_type, gnu_low); + if (gnu_high && TREE_TYPE (gnu_high) != gnu_type) + gnu_high = convert (gnu_type, gnu_high); + + if (gnu_low && gnu_high) + gnu_test + = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, + build_binary_op (GE_EXPR, boolean_type_node, + gnu_operand, gnu_low, true), + build_binary_op (LE_EXPR, boolean_type_node, + gnu_operand, gnu_high, true), + true); + else if (gnu_low) + gnu_test + = build_binary_op (EQ_EXPR, boolean_type_node, gnu_operand, gnu_low, + true); else - result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result, - this_test, true); + gnu_test = boolean_true_node; + + if (gnu_result == boolean_false_node) + gnu_result = gnu_test; + else + gnu_result + = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_result, + gnu_test, true); } - return result; + return gnu_result; } /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of @@ -7213,6 +7269,28 @@ compare_field_bitpos (const PTR rt1, const PTR rt2) return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2)); } +/* Sort the LIST of fields in reverse order of increasing position. */ + +static tree +reverse_sort_field_list (tree list) +{ + const int len = list_length (list); + tree *field_arr = XALLOCAVEC (tree, len); + + for (int i = 0; list; list = DECL_CHAIN (list), i++) + field_arr[i] = list; + + qsort (field_arr, len, sizeof (tree), compare_field_bitpos); + + for (int i = 0; i < len; i++) + { + DECL_CHAIN (field_arr[i]) = list; + list = field_arr[i]; + } + + return list; +} + /* Reverse function from gnat_to_gnu_field: return the GNAT field present in either GNAT_COMPONENT_LIST or the discriminants of GNAT_RECORD_TYPE, and corresponding to the GNU tree GNU_FIELD. */ @@ -7257,31 +7335,44 @@ warn_on_field_placement (tree gnu_field, Node_Id gnat_component_list, if (!Comes_From_Source (gnat_record_type)) return; + Entity_Id gnat_field + = gnu_field_to_gnat (gnu_field, gnat_component_list, gnat_record_type); + gcc_assert (Present (gnat_field)); + const char *msg1 = in_variant ? "?variant layout may cause performance issues" : "?record layout may cause performance issues"; const char *msg2 - = field_has_self_size (gnu_field) - ? "?component & whose length depends on a discriminant" - : field_has_variable_size (gnu_field) - ? "?component & whose length is not fixed" - : "?component & whose length is not multiple of a byte"; + = Ekind (gnat_field) == E_Discriminant + ? "?discriminant & whose length is not multiple of a byte" + : field_has_self_size (gnu_field) + ? "?component & whose length depends on a discriminant" + : field_has_variable_size (gnu_field) + ? "?component & whose length is not fixed" + : "?component & whose length is not multiple of a byte"; const char *msg3 = do_reorder ? "?comes too early and was moved down" : "?comes too early and ought to be moved down"; - Entity_Id gnat_field - = gnu_field_to_gnat (gnu_field, gnat_component_list, gnat_record_type); - - gcc_assert (Present (gnat_field)); - post_error (msg1, gnat_field); post_error_ne (msg2, gnat_field, gnat_field); post_error (msg3, gnat_field); } +/* Likewise but for every field present on GNU_FIELD_LIST. */ + +static void +warn_on_list_placement (tree gnu_field_list, Node_Id gnat_component_list, + Entity_Id gnat_record_type, bool in_variant, + bool do_reorder) +{ + for (tree gnu_tmp = gnu_field_list; gnu_tmp; gnu_tmp = DECL_CHAIN (gnu_tmp)) + warn_on_field_placement (gnu_tmp, gnat_component_list, gnat_record_type, + in_variant, do_reorder); +} + /* Structure holding information for a given variant. */ typedef struct vinfo { @@ -7856,11 +7947,18 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type, if (tmp_bitp_size != 0) { if (w_reorder && tmp_last_reorder_field_type < 2) - warn_on_field_placement (gnu_tmp_bitp_list - ? gnu_tmp_bitp_list : gnu_last, - gnat_component_list, - gnat_record_type, in_variant, - do_reorder); + { + if (gnu_tmp_bitp_list) + warn_on_list_placement (gnu_tmp_bitp_list, + gnat_component_list, + gnat_record_type, in_variant, + do_reorder); + else + warn_on_field_placement (gnu_last, + gnat_component_list, + gnat_record_type, in_variant, + do_reorder); + } if (do_reorder) gnu_bitp_list = chainon (gnu_tmp_bitp_list, gnu_bitp_list); @@ -7914,10 +8012,16 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type, if (last_reorder_field_type == 2 && tmp_bitp_size != 0 && tmp_last_reorder_field_type < 2) - warn_on_field_placement (gnu_tmp_bitp_list - ? gnu_tmp_bitp_list : gnu_field_list, - gnat_component_list, gnat_record_type, - in_variant, do_reorder); + { + if (gnu_tmp_bitp_list) + warn_on_list_placement (gnu_tmp_bitp_list, + gnat_component_list, gnat_record_type, + in_variant, do_reorder); + else + warn_on_field_placement (gnu_field_list, + gnat_component_list, gnat_record_type, + in_variant, do_reorder); + } } if (do_reorder) @@ -8022,7 +8126,23 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type, /* Chain the variant part at the end of the field list. */ if (gnu_variant_part) - gnu_field_list = chainon (gnu_field_list, gnu_variant_part); + { + /* We make an exception if the variant part is at offset 0, has a fixed + size, and there is a single rep'ed field placed after it because, in + this case, there is an obvious order of increasing position. */ + if (variants_have_rep + && TREE_CODE (DECL_SIZE_UNIT (gnu_variant_part)) == INTEGER_CST + && gnu_rep_list + && gnu_field_list == gnu_rep_list + && !tree_int_cst_lt (DECL_FIELD_OFFSET (gnu_rep_list), + DECL_SIZE_UNIT (gnu_variant_part))) + { + DECL_CHAIN (gnu_variant_part) = gnu_field_list; + gnu_field_list = gnu_variant_part; + } + else + gnu_field_list = chainon (gnu_field_list, gnu_variant_part); + } if (cancel_alignment) SET_TYPE_ALIGN (gnu_record_type, 0); @@ -8512,7 +8632,8 @@ build_variant_list (tree qual_union_type, vec<subst_pair> subst_list, if (!integer_zerop (qual)) { tree variant_type = TREE_TYPE (gnu_field), variant_subpart; - variant_desc v = { variant_type, gnu_field, qual, NULL_TREE }; + variant_desc v + = { variant_type, gnu_field, qual, NULL_TREE, NULL_TREE }; gnu_list.safe_push (v); @@ -9286,7 +9407,6 @@ create_variant_part_from (tree old_variant_part, /* Finish up the new variant and create the field. */ finish_record_type (new_variant, nreverse (field_list), 2, debug_info_p); - compute_record_mode (new_variant); create_type_decl (TYPE_NAME (new_variant), new_variant, true, debug_info_p, Empty); @@ -9304,7 +9424,6 @@ create_variant_part_from (tree old_variant_part, reverse the field list because VARIANT_LIST has been traversed in reverse order. */ finish_record_type (new_union_type, union_field_list, 2, debug_info_p); - compute_record_mode (new_union_type); create_type_decl (TYPE_NAME (new_union_type), new_union_type, true, debug_info_p, Empty); @@ -9402,7 +9521,8 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type, { const bool is_subtype = (Ekind (gnat_new_type) == E_Record_Subtype); tree gnu_field_list = NULL_TREE; - bool selected_variant, all_constant_pos = true; + tree gnu_variable_field_list = NULL_TREE; + bool selected_variant; vec<variant_desc> gnu_variant_list; /* Look for REP and variant parts in the old type. */ @@ -9486,6 +9606,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type, tree gnu_context = DECL_CONTEXT (gnu_old_field); tree gnu_field, gnu_field_type, gnu_size, gnu_pos; tree gnu_cont_type, gnu_last = NULL_TREE; + variant_desc *v = NULL; /* If the type is the same, retrieve the GCC type from the old field to take into account possible adjustments. */ @@ -9534,7 +9655,6 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type, gnu_cont_type = gnu_new_type; else { - variant_desc *v; unsigned int i; tree rep_part; @@ -9547,7 +9667,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type, if (v) gnu_cont_type = selected_variant ? gnu_new_type : v->new_type; else - /* The front-end may pass us "ghost" components if it fails to + /* The front-end may pass us zombie components if it fails to recognize that a constrain statically selects a particular variant. Discard them. */ continue; @@ -9563,8 +9683,16 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type, /* If the context is a variant, put it in the new variant directly. */ if (gnu_cont_type != gnu_new_type) { - DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type); - TYPE_FIELDS (gnu_cont_type) = gnu_field; + if (TREE_CODE (gnu_pos) == INTEGER_CST) + { + DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type); + TYPE_FIELDS (gnu_cont_type) = gnu_field; + } + else + { + DECL_CHAIN (gnu_field) = v->aux; + v->aux = gnu_field; + } } /* To match the layout crafted in components_to_record, if this is @@ -9583,12 +9711,18 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type, /* Otherwise, put it after the other fields. */ else { - DECL_CHAIN (gnu_field) = gnu_field_list; - gnu_field_list = gnu_field; - if (!gnu_last) - gnu_last = gnu_field; - if (TREE_CODE (gnu_pos) != INTEGER_CST) - all_constant_pos = false; + if (TREE_CODE (gnu_pos) == INTEGER_CST) + { + DECL_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + if (!gnu_last) + gnu_last = gnu_field; + } + else + { + DECL_CHAIN (gnu_field) = gnu_variable_field_list; + gnu_variable_field_list = gnu_field; + } } /* For a stored discriminant in a derived type, replace the field. */ @@ -9601,31 +9735,32 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type, save_gnu_tree (gnat_field, gnu_field, false); } - /* If there is no variant list or a selected variant and the fields all have - constant position, put them in order of increasing position to match that - of constant CONSTRUCTORs. */ - if ((!gnu_variant_list.exists () || selected_variant) && all_constant_pos) - { - const int len = list_length (gnu_field_list); - tree *field_arr = XALLOCAVEC (tree, len), t = gnu_field_list; + /* Put the fields with fixed position in order of increasing position. */ + if (gnu_field_list) + gnu_field_list = reverse_sort_field_list (gnu_field_list); - for (int i = 0; t; t = DECL_CHAIN (t), i++) - field_arr[i] = t; + /* Put the fields with variable position at the end. */ + if (gnu_variable_field_list) + gnu_field_list = chainon (gnu_variable_field_list, gnu_field_list); - qsort (field_arr, len, sizeof (tree), compare_field_bitpos); + /* If there is a variant list and no selected variant, we need to create the + nest of variant parts from the old nest. */ + if (gnu_variant_list.exists () && !selected_variant) + { + variant_desc *v; + unsigned int i; - gnu_field_list = NULL_TREE; - for (int i = 0; i < len; i++) + /* Same processing as above for the fields of each variant. */ + FOR_EACH_VEC_ELT (gnu_variant_list, i, v) { - DECL_CHAIN (field_arr[i]) = gnu_field_list; - gnu_field_list = field_arr[i]; + if (TYPE_FIELDS (v->new_type)) + TYPE_FIELDS (v->new_type) + = reverse_sort_field_list (TYPE_FIELDS (v->new_type)); + if (v->aux) + TYPE_FIELDS (v->new_type) + = chainon (v->aux, TYPE_FIELDS (v->new_type)); } - } - /* If there is a variant list and no selected variant, we need to create the - nest of variant parts from the old nest. */ - else if (gnu_variant_list.exists () && !selected_variant) - { tree new_variant_part = create_variant_part_from (gnu_variant_part, gnu_variant_list, gnu_new_type, gnu_pos_list, @@ -9637,17 +9772,10 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type, gnu_variant_list.release (); gnu_subst_list.release (); - gnu_field_list = nreverse (gnu_field_list); - /* If NEW_TYPE is a subtype, it inherits all the attributes from OLD_TYPE. Otherwise sizes and alignment must be computed independently. */ - if (is_subtype) - { - finish_record_type (gnu_new_type, gnu_field_list, 2, debug_info_p); - compute_record_mode (gnu_new_type); - } - else - finish_record_type (gnu_new_type, gnu_field_list, 1, debug_info_p); + finish_record_type (gnu_new_type, nreverse (gnu_field_list), + is_subtype ? 2 : 1, debug_info_p); /* Now go through the entities again looking for Itypes that we have not yet elaborated (e.g. Etypes of fields that have Original_Components). */ @@ -9766,6 +9894,7 @@ substitute_in_type (tree t, tree f, tree r) return build_complex_type (nt); case FUNCTION_TYPE: + case METHOD_TYPE: /* These should never show up here. */ gcc_unreachable (); diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index f700374..a75cb90 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2017, Free Software Foundation, Inc. * + * Copyright (C) 1992-2018, 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- * @@ -77,9 +77,9 @@ extern tree end_stmt_group (void); /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */ extern void set_block_for_group (tree); -/* Add a declaration statement for GNU_DECL to the current BLOCK_STMT node. - Get SLOC from GNAT_ENTITY. */ -extern void add_decl_expr (tree gnu_decl, Entity_Id gnat_entity); +/* Add a declaration statement for GNU_DECL to the current statement group. + Get the SLOC to be put onto the statement from GNAT_NODE. */ +extern void add_decl_expr (tree gnu_decl, Node_Id gnat_node); /* Mark nodes rooted at T with TREE_VISITED and types as having their sized gimplified. We use this to indicate all variable sizes and @@ -110,10 +110,6 @@ extern void elaborate_entity (Entity_Id gnat_entity); /* Get the unpadded version of a GNAT type. */ extern tree get_unpadded_type (Entity_Id gnat_entity); -/* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is - a C++ imported method or equivalent. */ -extern bool is_cplusplus_method (Entity_Id gnat_entity); - /* Create a record type that contains a SIZE bytes long field of TYPE with a starting bit position so that it is aligned to ALIGN bits, and leaving at least ROOM bytes free before the field. BASE_ALIGN is the alignment the @@ -548,7 +544,7 @@ extern int gnat_types_compatible_p (tree t1, tree t2); /* Return true if EXPR is a useless type conversion. */ extern bool gnat_useless_type_conversion (tree expr); -/* Return true if T, a FUNCTION_TYPE, has the specified list of flags. */ +/* Return true if T, a {FUNCTION,METHOD}_TYPE, has the specified flags. */ extern bool fntype_same_flags_p (const_tree, tree, bool, bool, bool); /* Create an expression whose value is that of EXPR, @@ -1075,7 +1071,7 @@ maybe_vector_array (tree exp) static inline unsigned HOST_WIDE_INT ceil_pow2 (unsigned HOST_WIDE_INT x) { - return (unsigned HOST_WIDE_INT) 1 << (floor_log2 (x - 1) + 1); + return (unsigned HOST_WIDE_INT) 1 << ceil_log2 (x); } /* Return true if EXP, a CALL_EXPR, is an atomic load. */ @@ -1172,3 +1168,16 @@ maybe_debug_type (tree type) return type; } + +/* Like build_qualified_type, but TYPE_QUALS is added to the existing + qualifiers on TYPE. */ + +static inline tree +change_qualified_type (tree type, int type_quals) +{ + /* Qualifiers must be put on the associated array type. */ + if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) + return type; + + return build_qualified_type (type, TYPE_QUALS (type) | type_quals); +} diff --git a/gcc/ada/gcc-interface/lang.opt b/gcc/ada/gcc-interface/lang.opt index 17c6dc8..18ff6b0 100644 --- a/gcc/ada/gcc-interface/lang.opt +++ b/gcc/ada/gcc-interface/lang.opt @@ -80,6 +80,10 @@ fsigned-char Ada AdaWhy AdaSCIL Make \"char\" signed by default. +funsigned-char +Ada AdaWhy AdaSCIL +Make \"char\" unsigned by default. + gant Ada AdaWhy AdaSCIL Driver Joined Undocumented RejectNegative Catch typos. diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index e4efa21..9ee73b9 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -138,8 +138,9 @@ gnat_option_lang_mask (void) are marked as Ada-specific. Return true on success or false on failure. */ static bool -gnat_handle_option (size_t scode, const char *arg, int value, int kind, - location_t loc, const struct cl_option_handlers *handlers) +gnat_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value, + int kind, location_t loc, + const struct cl_option_handlers *handlers) { enum opt_code code = (enum opt_code) scode; @@ -170,6 +171,7 @@ gnat_handle_option (size_t scode, const char *arg, int value, int kind, case OPT_fshort_enums: case OPT_fsigned_char: + case OPT_funsigned_char: /* These are handled by the middle-end. */ break; @@ -472,6 +474,7 @@ gnat_print_type (FILE *file, tree node, int indent) switch (TREE_CODE (node)) { case FUNCTION_TYPE: + case METHOD_TYPE: print_node (file, "ci/co list", TYPE_CI_CO_LIST (node), indent + 4); break; @@ -683,12 +686,12 @@ gnat_get_fixed_point_type_info (const_tree type, /* Return true if types T1 and T2 are identical for type hashing purposes. Called only after doing all language independent checks. At present, - this function is only called when both types are FUNCTION_TYPE. */ + this is only called when both types are FUNCTION_TYPE or METHOD_TYPE. */ static bool gnat_type_hash_eq (const_tree t1, const_tree t2) { - gcc_assert (TREE_CODE (t1) == FUNCTION_TYPE); + gcc_assert (FUNC_OR_METHOD_TYPE_P (t1) && TREE_CODE (t1) == TREE_CODE (t2)); return fntype_same_flags_p (t1, TYPE_CI_CO_LIST (t2), TYPE_RETURN_UNCONSTRAINED_P (t2), TYPE_RETURN_BY_DIRECT_REF_P (t2), @@ -736,25 +739,25 @@ gnat_type_max_size (const_tree gnu_type) /* First see what we can get from TYPE_SIZE_UNIT, which might not be constant even for simple expressions if it has already been elaborated and possibly replaced by a VAR_DECL. */ - tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true); + tree max_size_unit = max_size (TYPE_SIZE_UNIT (gnu_type), true); /* If we don't have a constant, try to look at attributes which should have stayed untouched. */ - if (!tree_fits_uhwi_p (max_unitsize)) + if (!tree_fits_uhwi_p (max_size_unit)) { /* For record types, see what we can get from TYPE_ADA_SIZE. */ if (RECORD_OR_UNION_TYPE_P (gnu_type) && !TYPE_FAT_POINTER_P (gnu_type) && TYPE_ADA_SIZE (gnu_type)) { - tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true); + tree max_ada_size = max_size (TYPE_ADA_SIZE (gnu_type), true); /* If we have succeeded in finding a constant, round it up to the type's alignment and return the result in units. */ - if (tree_fits_uhwi_p (max_adasize)) - max_unitsize + if (tree_fits_uhwi_p (max_ada_size)) + max_size_unit = size_binop (CEIL_DIV_EXPR, - round_up (max_adasize, TYPE_ALIGN (gnu_type)), + round_up (max_ada_size, TYPE_ALIGN (gnu_type)), bitsize_unit_node); } @@ -784,7 +787,7 @@ gnat_type_max_size (const_tree gnu_type) = fold_build2 (PLUS_EXPR, ctype, fold_build2 (MINUS_EXPR, ctype, hb, lb), build_int_cst (ctype, 1)); - max_unitsize + max_size_unit = fold_build2 (MULT_EXPR, sizetype, fold_convert (sizetype, length), TYPE_SIZE_UNIT (TREE_TYPE (gnu_type))); @@ -793,7 +796,7 @@ gnat_type_max_size (const_tree gnu_type) } } - return max_unitsize; + return max_size_unit; } static tree get_array_bit_stride (tree); diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index dabf2bb..31e098a 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -246,7 +246,7 @@ static tree maybe_implicit_deref (tree); static void set_expr_location_from_node (tree, Node_Id, bool = false); static void set_gnu_expr_location_from_node (tree, Node_Id); static bool set_end_locus_from_node (tree, Node_Id); -static int lvalue_required_p (Node_Id, tree, bool, bool, bool); +static int lvalue_required_p (Node_Id, tree, bool, bool); static tree build_raise_check (int, enum exception_info_kind); static tree create_init_temporary (const char *, tree, tree *, Node_Id); @@ -806,8 +806,8 @@ lvalue_required_for_attribute_p (Node_Id gnat_node) is the type that will be used for GNAT_NODE in the translated GNU tree. CONSTANT indicates whether the underlying object represented by GNAT_NODE is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates - whether its value is the address of a constant and ALIASED whether it is - aliased. If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored. + whether its value is the address of another constant. If it isn't, then + ADDRESS_OF_CONSTANT is ignored. The function climbs up the GNAT tree starting from the node and returns 1 upon encountering a node that effectively requires an lvalue downstream. @@ -816,7 +816,7 @@ lvalue_required_for_attribute_p (Node_Id gnat_node) static int lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant, - bool address_of_constant, bool aliased) + bool address_of_constant) { Node_Id gnat_parent = Parent (gnat_node), gnat_temp; @@ -861,14 +861,12 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant, if (Prefix (gnat_parent) != gnat_node) return 0; - aliased |= Has_Aliased_Components (Etype (gnat_node)); return lvalue_required_p (gnat_parent, gnu_type, constant, - address_of_constant, aliased); + address_of_constant); case N_Selected_Component: - aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent))); return lvalue_required_p (gnat_parent, gnu_type, constant, - address_of_constant, aliased); + address_of_constant); case N_Object_Renaming_Declaration: /* We need to preserve addresses through a renaming. */ @@ -908,7 +906,7 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant, an intermediate conversion that is meant to be purely formal. */ return lvalue_required_p (gnat_parent, get_unpadded_type (Etype (gnat_parent)), - constant, address_of_constant, aliased); + constant, address_of_constant); case N_Allocator: /* We should only reach here through the N_Qualified_Expression case. @@ -922,7 +920,7 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant, if (constant && address_of_constant) return lvalue_required_p (gnat_parent, get_unpadded_type (Etype (gnat_parent)), - true, false, true); + true, false); /* ... fall through ... */ @@ -1123,8 +1121,8 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) && !Is_Imported (gnat_temp) && Present (Address_Clause (gnat_temp))) { - require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true, - false, Is_Aliased (gnat_temp)); + require_lvalue + = lvalue_required_p (gnat_node, gnu_result_type, true, false); use_constant_initializer = !require_lvalue; } @@ -1161,7 +1159,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) else if (TREE_CODE (gnu_result) == CONST_DECL && !(DECL_CONST_ADDRESS_P (gnu_result) && lvalue_required_p (gnat_node, gnu_result_type, true, - true, false))) + true))) gnu_result = DECL_INITIAL (gnu_result); /* If it's a renaming pointer, get to the renamed object. */ @@ -1201,7 +1199,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) if ((!constant_only || address_of_constant) && require_lvalue < 0) require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true, - address_of_constant, Is_Aliased (gnat_temp)); + address_of_constant); /* Finally retrieve the initializer if this is deemed valid. */ if ((constant_only && !address_of_constant) || !require_lvalue) @@ -1217,8 +1215,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) { if (require_lvalue < 0) require_lvalue - = lvalue_required_p (gnat_node, gnu_result_type, true, false, - Is_Aliased (gnat_temp)); + = lvalue_required_p (gnat_node, gnu_result_type, true, false); if (!require_lvalue) gnu_result = fold_constant_decl_in_expr (gnu_result); } @@ -1229,7 +1226,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) of a discriminated type whose full view can be elaborated statically, to avoid problematic conversions to the nominal subtype. But remove any padding from the resulting type. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE + if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_result)) || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type) || (Ekind (gnat_temp) == E_Constant && Present (Full_View (gnat_temp)) @@ -1733,15 +1730,14 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) since it can use a special calling convention on some platforms, which cannot be propagated to the access type. */ else if (attribute == Attr_Access - && Nkind (gnat_prefix) == N_Identifier - && is_cplusplus_method (Entity (gnat_prefix))) + && TREE_CODE (TREE_TYPE (gnu_prefix)) == METHOD_TYPE) post_error ("access to C++ constructor or member function not allowed", gnat_node); /* For other address attributes applied to a nested function, find an inner ADDR_EXPR and annotate it so that we can issue a useful warning with -Wtrampolines. */ - else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE) + else if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_prefix))) { gnu_expr = remove_conversions (gnu_result, false); @@ -4286,7 +4282,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, Node_Id gnat_actual; bool sync; - gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE); + gcc_assert (FUNC_OR_METHOD_TYPE_P (gnu_subprog_type)); /* If we are calling a stubbed function, raise Program_Error, but Elaborate all our args first. */ @@ -7860,7 +7856,7 @@ gnat_to_gnu (Node_Id gnat_node) || kind == N_Indexed_Component || kind == N_Selected_Component) && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE - && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false)) + && !lvalue_required_p (gnat_node, gnu_result_type, false, false)) { gnu_result = build_binary_op (NE_EXPR, gnu_result_type, @@ -8122,9 +8118,7 @@ add_stmt_force (tree gnu_stmt) void add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node) { - /* Do not emit a location for renamings that come from generic instantiation, - they are likely to disturb debugging. */ - if (Present (gnat_node) && !renaming_from_instantiation_p (gnat_node)) + if (Present (gnat_node)) set_expr_location_from_node (gnu_stmt, gnat_node); add_stmt (gnu_stmt); } @@ -8140,10 +8134,10 @@ add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node) } /* Add a declaration statement for GNU_DECL to the current statement group. - Get SLOC from Entity_Id. */ + Get the SLOC to be put onto the statement from GNAT_NODE. */ void -add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) +add_decl_expr (tree gnu_decl, Node_Id gnat_node) { tree type = TREE_TYPE (gnu_decl); tree gnu_stmt, gnu_init; @@ -8182,7 +8176,7 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) MARK_VISITED (TYPE_ADA_SIZE (type)); } else - add_stmt_with_node (gnu_stmt, gnat_entity); + add_stmt_with_node (gnu_stmt, gnat_node); /* If this is a variable and an initializer is attached to it, it must be valid for the context. Similar to init_const in create_var_decl. */ @@ -8206,7 +8200,7 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) gnu_decl = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl); gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_decl, gnu_init); - add_stmt_with_node (gnu_stmt, gnat_entity); + add_stmt_with_node (gnu_stmt, gnat_node); } } @@ -8748,7 +8742,7 @@ process_freeze_entity (Node_Id gnat_node) if (gnu_old && ((TREE_CODE (gnu_old) == FUNCTION_DECL && (kind == E_Function || kind == E_Procedure)) - || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE + || (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_old)) && kind == E_Subprogram_Type))) return; @@ -10008,6 +10002,32 @@ Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column) return true; } +/* Return whether GNAT_NODE is a defining identifier for a renaming that comes + from the parameter association for the instantiation of a generic. We do + not want to emit source location for them: the code generated for their + initialization is likely to disturb debugging. */ + +bool +renaming_from_instantiation_p (Node_Id gnat_node) +{ + if (Nkind (gnat_node) != N_Defining_Identifier + || !Is_Object (gnat_node) + || Comes_From_Source (gnat_node) + || !Present (Renamed_Object (gnat_node))) + return false; + + /* Get the object declaration of the renamed object, if any and if the + renamed object is a mere identifier. */ + gnat_node = Renamed_Object (gnat_node); + if (Nkind (gnat_node) != N_Identifier) + return false; + + gnat_node = Parent (Entity (gnat_node)); + return (Present (gnat_node) + && Nkind (gnat_node) == N_Object_Declaration + && Present (Corresponding_Generic_Association (gnat_node))); +} + /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and don't do anything if it doesn't correspond to a source location. And, if CLEAR_COLUMN is true, set the column information to 0. */ @@ -10017,6 +10037,16 @@ set_expr_location_from_node (tree node, Node_Id gnat_node, bool clear_column) { location_t locus; + /* Do not set a location for constructs likely to disturb debugging. */ + if (Nkind (gnat_node) == N_Defining_Identifier) + { + if (Is_Type (gnat_node) && Is_Actual_Subtype (gnat_node)) + return; + + if (renaming_from_instantiation_p (gnat_node)) + return; + } + if (!Sloc_to_locus (Sloc (gnat_node), &locus, clear_column)) return; diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index d415f49..cc1fe77 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -391,15 +391,13 @@ make_dummy_type (Entity_Id gnat_type) SET_DUMMY_NODE (gnat_equiv, gnu_type); - /* Create a debug type so that debug info consumers only see an unspecified - type. */ + /* Create a debug type so that debuggers only see an unspecified type. */ if (Needs_Debug_Info (gnat_type)) { debug_type = make_node (LANG_TYPE); - SET_TYPE_DEBUG_TYPE (gnu_type, debug_type); - TYPE_NAME (debug_type) = TYPE_NAME (gnu_type); TYPE_ARTIFICIAL (debug_type) = TYPE_ARTIFICIAL (gnu_type); + SET_TYPE_DEBUG_TYPE (gnu_type, debug_type); } return gnu_type; @@ -1054,12 +1052,6 @@ make_packable_type (tree type, bool in_record, unsigned int max_align) new_field_list = new_field; } - finish_record_type (new_type, nreverse (new_field_list), 2, false); - relate_alias_sets (new_type, type, ALIAS_SET_COPY); - if (TYPE_STUB_DECL (type)) - SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type), - DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type))); - /* If this is a padding record, we never want to make the size smaller than what was specified. For QUAL_UNION_TYPE, also copy the size. */ if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE) @@ -1077,7 +1069,13 @@ make_packable_type (tree type, bool in_record, unsigned int max_align) if (!TYPE_CONTAINS_TEMPLATE_P (type)) SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type)); - compute_record_mode (new_type); + finish_record_type (new_type, nreverse (new_field_list), 2, false); + relate_alias_sets (new_type, type, ALIAS_SET_COPY); + if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + SET_TYPE_DEBUG_TYPE (new_type, TYPE_DEBUG_TYPE (type)); + else if (TYPE_STUB_DECL (type)) + SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type), + DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type))); /* Try harder to get a packable type if necessary, for example in case the record itself contains a BLKmode field. */ @@ -1419,7 +1417,7 @@ maybe_pad_type (tree type, tree size, unsigned int align, } if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) - SET_TYPE_DEBUG_TYPE (record, type); + SET_TYPE_DEBUG_TYPE (record, maybe_debug_type (type)); /* Unless debugging information isn't being written for the input type, write a record that shows what we are a subtype of and also make a @@ -1686,7 +1684,7 @@ record_builtin_type (const char *name, tree type, bool artificial_p) integral types are unsigned. Unfortunately the signedness of 'char' in C is implementation-defined - and GCC even has the option -fsigned-char to toggle it at run time. + and GCC even has the option -f[un]signed-char to toggle it at run time. Since GNAT's philosophy is to be compatible with C by default, to wit Interfaces.C.char is defined as a mere copy of Character, we may need to declare character types as signed types in GENERIC and generate the @@ -1951,33 +1949,40 @@ finish_record_type (tree record_type, tree field_list, int rep_level, if (code == QUAL_UNION_TYPE) nreverse (field_list); - if (rep_level < 2) + /* We need to set the regular sizes if REP_LEVEL is one. */ + if (rep_level == 1) { /* If this is a padding record, we never want to make the size smaller than what was specified in it, if any. */ if (TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type)) size = TYPE_SIZE (record_type); + tree size_unit = had_size_unit + ? TYPE_SIZE_UNIT (record_type) + : convert (sizetype, + size_binop (CEIL_DIV_EXPR, size, + bitsize_unit_node)); + const unsigned int align = TYPE_ALIGN (record_type); + + TYPE_SIZE (record_type) = variable_size (round_up (size, align)); + TYPE_SIZE_UNIT (record_type) + = variable_size (round_up (size_unit, align / BITS_PER_UNIT)); + } + + /* We need to set the Ada size if REP_LEVEL is zero or one. */ + if (rep_level < 2) + { /* Now set any of the values we've just computed that apply. */ if (!TYPE_FAT_POINTER_P (record_type) && !TYPE_CONTAINS_TEMPLATE_P (record_type)) SET_TYPE_ADA_SIZE (record_type, ada_size); + } - if (rep_level > 0) - { - tree size_unit = had_size_unit - ? TYPE_SIZE_UNIT (record_type) - : convert (sizetype, - size_binop (CEIL_DIV_EXPR, size, - bitsize_unit_node)); - unsigned int align = TYPE_ALIGN (record_type); - - TYPE_SIZE (record_type) = variable_size (round_up (size, align)); - TYPE_SIZE_UNIT (record_type) - = variable_size (round_up (size_unit, align / BITS_PER_UNIT)); - - compute_record_mode (record_type); - } + /* We need to set the mode if REP_LEVEL is one or two. */ + if (rep_level > 0) + { + compute_record_mode (record_type); + finish_bitfield_layout (record_type); } /* Reset the TYPE_MAX_ALIGN field since it's private to gigi. */ @@ -2933,37 +2938,6 @@ value_factor_p (tree value, HOST_WIDE_INT factor) return false; } -/* Return whether GNAT_NODE is a defining identifier for a renaming that comes - from the parameter association for the instantiation of a generic. We do - not want to emit source location for them: the code generated for their - initialization is likely to disturb debugging. */ - -bool -renaming_from_instantiation_p (Node_Id gnat_node) -{ - if (Nkind (gnat_node) != N_Defining_Identifier - || !Is_Object (gnat_node) - || Comes_From_Source (gnat_node) - || !Present (Renamed_Object (gnat_node))) - return false; - - /* Get the object declaration of the renamed object, if any and if the - renamed object is a mere identifier. */ - gnat_node = Renamed_Object (gnat_node); - if (Nkind (gnat_node) != N_Identifier) - return false; - - gnat_node = Entity (gnat_node); - if (!Present (Parent (gnat_node))) - return false; - - gnat_node = Parent (gnat_node); - return - (Present (gnat_node) - && Nkind (gnat_node) == N_Object_Declaration - && Present (Corresponding_Generic_Association (gnat_node))); -} - /* Defer the initialization of DECL's DECL_CONTEXT attribute, scheduling to feed it with the elaboration of GNAT_SCOPE. */ @@ -3217,9 +3191,9 @@ create_label_decl (tree name, Node_Id gnat_node) } /* Return a FUNCTION_DECL node. NAME is the name of the subprogram, ASM_NAME - its assembler name, TYPE its type (a FUNCTION_TYPE node), PARAM_DECL_LIST - the list of its parameters (a list of PARM_DECL nodes chained through the - DECL_CHAIN field). + its assembler name, TYPE its type (a FUNCTION_TYPE or METHOD_TYPE node), + PARAM_DECL_LIST the list of its parameters (a list of PARM_DECL nodes + chained through the DECL_CHAIN field). INLINE_STATUS describes the inline flags to be set on the FUNCTION_DECL. @@ -3322,8 +3296,14 @@ finish_subprog_decl (tree decl, tree asm_name, tree type) DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (type); DECL_RESULT (decl) = result_decl; + /* Propagate the "const" property. */ TREE_READONLY (decl) = TYPE_READONLY (type); - TREE_SIDE_EFFECTS (decl) = TREE_THIS_VOLATILE (decl) = TYPE_VOLATILE (type); + + /* Propagate the "pure" property. */ + DECL_PURE_P (decl) = TYPE_RESTRICT (type); + + /* Propagate the "noreturn" property. */ + TREE_THIS_VOLATILE (decl) = TYPE_VOLATILE (type); if (asm_name) { @@ -3609,7 +3589,7 @@ gnat_useless_type_conversion (tree expr) return false; } -/* Return true if T, a FUNCTION_TYPE, has the specified list of flags. */ +/* Return true if T, a {FUNCTION,METHOD}_TYPE, has the specified flags. */ bool fntype_same_flags_p (const_tree t, tree cico_list, bool return_unconstrained_p, @@ -6221,8 +6201,7 @@ handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args), && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) TREE_TYPE (*node) = build_pointer_type - (build_type_variant (TREE_TYPE (type), - TYPE_READONLY (TREE_TYPE (type)), 1)); + (change_qualified_type (TREE_TYPE (type), TYPE_QUAL_VOLATILE)); else { warning (OPT_Wattributes, "%qs attribute ignored", diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index fe56691..47912aa 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -29,7 +29,6 @@ with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; -with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -50,18 +49,16 @@ package body Ghost is -- Data strictures -- --------------------- - -- The following table contains the N_Compilation_Unit node for a unit that - -- is either subject to pragma Ghost with policy Ignore or contains ignored - -- Ghost code. The table is used in the removal of ignored Ghost code from - -- units. + -- The following table contains all ignored Ghost nodes that must be + -- eliminated from the tree by routine Remove_Ignored_Ghost_Code. - package Ignored_Ghost_Units is new Table.Table ( + package Ignored_Ghost_Nodes is new Table.Table ( Table_Component_Type => Node_Id, Table_Index_Type => Int, Table_Low_Bound => 0, - Table_Initial => Alloc.Ignored_Ghost_Units_Initial, - Table_Increment => Alloc.Ignored_Ghost_Units_Increment, - Table_Name => "Ignored_Ghost_Units"); + Table_Initial => Alloc.Ignored_Ghost_Nodes_Initial, + Table_Increment => Alloc.Ignored_Ghost_Nodes_Increment, + Table_Name => "Ignored_Ghost_Nodes"); ----------------------- -- Local subprograms -- @@ -98,37 +95,9 @@ package body Ghost is -- Convert a Ghost mode denoted by name Mode into its respective enumerated -- value. - procedure Propagate_Ignored_Ghost_Code (N : Node_Id); - -- Signal all enclosing scopes that they now contain at least one ignored - -- Ghost node denoted by N. Add the compilation unit containing N to table - -- Ignored_Ghost_Units for post processing. - - ---------------------------- - -- Add_Ignored_Ghost_Unit -- - ---------------------------- - - procedure Add_Ignored_Ghost_Unit (Unit : Node_Id) is - begin - pragma Assert (Nkind (Unit) = N_Compilation_Unit); - - -- Avoid duplicates in the table as pruning the same unit more than once - -- is wasteful. Since ignored Ghost code tends to be grouped up, check - -- the contents of the table in reverse. - - for Index in reverse Ignored_Ghost_Units.First .. - Ignored_Ghost_Units.Last - loop - -- If the unit is already present in the table, do not add it again - - if Unit = Ignored_Ghost_Units.Table (Index) then - return; - end if; - end loop; - - -- If we get here, then this is the first time the unit is being added - - Ignored_Ghost_Units.Append (Unit); - end Add_Ignored_Ghost_Unit; + procedure Record_Ignored_Ghost_Node (N : Node_Or_Entity_Id); + -- Save ignored Ghost node or entity N in table Ignored_Ghost_Nodes for + -- later elimination. ---------------------------- -- Check_Ghost_Completion -- @@ -913,7 +882,12 @@ package body Ghost is procedure Initialize is begin - Ignored_Ghost_Units.Init; + Ignored_Ghost_Nodes.Init; + + -- Set the soft link which enables Atree.Mark_New_Ghost_Node to record + -- an ignored Ghost node or entity. + + Set_Ignored_Ghost_Recording_Proc (Record_Ignored_Ghost_Node'Access); end Initialize; ------------------------ @@ -1030,6 +1004,28 @@ package body Ghost is --------------------------- function Is_Ignored_Ghost_Unit (N : Node_Id) return Boolean is + function Ultimate_Original_Node (Nod : Node_Id) return Node_Id; + -- Obtain the original node of arbitrary node Nod following a potential + -- chain of rewritings. + + ---------------------------- + -- Ultimate_Original_Node -- + ---------------------------- + + function Ultimate_Original_Node (Nod : Node_Id) return Node_Id is + Res : Node_Id; + + begin + Res := Nod; + while Original_Node (Res) /= Res loop + Res := Original_Node (Res); + end loop; + + return Res; + end Ultimate_Original_Node; + + -- Start of processing for Is_Ignored_Ghost_Unit + begin -- Inspect the original node of the unit in case removal of ignored -- Ghost code has already taken place. @@ -1037,7 +1033,7 @@ package body Ghost is return Nkind (N) = N_Compilation_Unit and then Is_Ignored_Ghost_Entity - (Defining_Entity (Original_Node (Unit (N)))); + (Defining_Entity (Ultimate_Original_Node (Unit (N)))); end Is_Ignored_Ghost_Unit; ------------------------- @@ -1176,8 +1172,8 @@ package body Ghost is procedure Lock is begin - Ignored_Ghost_Units.Release; - Ignored_Ghost_Units.Locked := True; + Ignored_Ghost_Nodes.Release; + Ignored_Ghost_Nodes.Locked := True; end Lock; ----------------------------------- @@ -1201,7 +1197,7 @@ package body Ghost is Install_Ghost_Region (Ignore, N); Set_Is_Ignored_Ghost_Node (N); - Propagate_Ignored_Ghost_Code (N); + Record_Ignored_Ghost_Node (N); end if; end if; end Mark_And_Set_Ghost_Assignment; @@ -1472,11 +1468,39 @@ package body Ghost is Install_Ghost_Region (Ignore, N); Set_Is_Ignored_Ghost_Node (N); - Propagate_Ignored_Ghost_Code (N); + Record_Ignored_Ghost_Node (N); end if; end if; end Mark_And_Set_Ghost_Procedure_Call; + ----------------------- + -- Mark_Ghost_Clause -- + ----------------------- + + procedure Mark_Ghost_Clause (N : Node_Id) is + Nam : Node_Id := Empty; + + begin + if Nkind (N) = N_Use_Package_Clause then + Nam := Name (N); + + elsif Nkind (N) = N_Use_Type_Clause then + Nam := Subtype_Mark (N); + + elsif Nkind (N) = N_With_Clause then + Nam := Name (N); + end if; + + if Present (Nam) + and then Is_Entity_Name (Nam) + and then Present (Entity (Nam)) + and then Is_Ignored_Ghost_Entity (Entity (Nam)) + then + Set_Is_Ignored_Ghost_Node (N); + Record_Ignored_Ghost_Node (N); + end if; + end Mark_Ghost_Clause; + ------------------------------------ -- Mark_Ghost_Declaration_Or_Body -- ------------------------------------ @@ -1502,7 +1526,7 @@ package body Ghost is Mark_Formals := True; Set_Is_Ignored_Ghost_Entity (Id); Set_Is_Ignored_Ghost_Node (N); - Propagate_Ignored_Ghost_Code (N); + Record_Ignored_Ghost_Node (N); end if; -- Mark all formal parameters when the related node denotes a subprogram @@ -1538,34 +1562,6 @@ package body Ghost is end Mark_Ghost_Declaration_Or_Body; ----------------------- - -- Mark_Ghost_Clause -- - ----------------------- - - procedure Mark_Ghost_Clause (N : Node_Id) is - Nam : Node_Id := Empty; - - begin - if Nkind (N) = N_Use_Package_Clause then - Nam := Name (N); - - elsif Nkind (N) = N_Use_Type_Clause then - Nam := Subtype_Mark (N); - - elsif Nkind (N) = N_With_Clause then - Nam := Name (N); - end if; - - if Present (Nam) - and then Is_Entity_Name (Nam) - and then Present (Entity (Nam)) - and then Is_Ignored_Ghost_Entity (Entity (Nam)) - then - Set_Is_Ignored_Ghost_Node (N); - Propagate_Ignored_Ghost_Code (N); - end if; - end Mark_Ghost_Clause; - - ----------------------- -- Mark_Ghost_Pragma -- ----------------------- @@ -1583,7 +1579,7 @@ package body Ghost is elsif Is_Ignored_Ghost_Entity (Id) then Set_Is_Ignored_Ghost_Pragma (N); Set_Is_Ignored_Ghost_Node (N); - Propagate_Ignored_Ghost_Code (N); + Record_Ignored_Ghost_Node (N); end if; end Mark_Ghost_Pragma; @@ -1635,168 +1631,90 @@ package body Ghost is end if; end Name_To_Ghost_Mode; - ---------------------------------- - -- Propagate_Ignored_Ghost_Code -- - ---------------------------------- - - procedure Propagate_Ignored_Ghost_Code (N : Node_Id) is - Nod : Node_Id; - Scop : Entity_Id; + ------------------------------- + -- Record_Ignored_Ghost_Node -- + ------------------------------- + procedure Record_Ignored_Ghost_Node (N : Node_Or_Entity_Id) is begin - -- Traverse the parent chain looking for blocks, packages, and - -- subprograms or their respective bodies. - - Nod := Parent (N); - while Present (Nod) loop - Scop := Empty; - - if Nkind (Nod) = N_Block_Statement - and then Present (Identifier (Nod)) - then - Scop := Entity (Identifier (Nod)); - - elsif Nkind_In (Nod, N_Package_Body, - N_Package_Declaration, - N_Subprogram_Body, - N_Subprogram_Declaration) - then - Scop := Defining_Entity (Nod); - end if; - - -- The current node denotes a scoping construct - - if Present (Scop) then - - -- Stop the traversal when the scope already contains ignored - -- Ghost code as all enclosing scopes have already been marked. - - if Contains_Ignored_Ghost_Code (Scop) then - exit; - - -- Otherwise mark this scope and keep climbing - - else - Set_Contains_Ignored_Ghost_Code (Scop); - end if; - end if; - - Nod := Parent (Nod); - end loop; - - -- The unit containing the ignored Ghost code must be post processed - -- before invoking the back end. + -- Save all "top level" ignored Ghost nodes which can be safely replaced + -- with a null statement. Note that there is need to save other kinds of + -- nodes because those will always be enclosed by some top level ignored + -- Ghost node. + + if Is_Body (N) + or else Is_Declaration (N) + or else Nkind (N) in N_Generic_Instantiation + or else Nkind (N) in N_Push_Pop_xxx_Label + or else Nkind (N) in N_Raise_xxx_Error + or else Nkind (N) in N_Representation_Clause + or else Nkind_In (N, N_Assignment_Statement, + N_Call_Marker, + N_Freeze_Entity, + N_Freeze_Generic_Entity, + N_Itype_Reference, + N_Pragma, + N_Procedure_Call_Statement, + N_Use_Package_Clause, + N_Use_Type_Clause, + N_Variable_Reference_Marker, + N_With_Clause) + then + -- Only ignored Ghost nodes must be recorded in the table - Add_Ignored_Ghost_Unit (Cunit (Get_Code_Unit (N))); - end Propagate_Ignored_Ghost_Code; + pragma Assert (Is_Ignored_Ghost_Node (N)); + Ignored_Ghost_Nodes.Append (N); + end if; + end Record_Ignored_Ghost_Node; ------------------------------- -- Remove_Ignored_Ghost_Code -- ------------------------------- procedure Remove_Ignored_Ghost_Code is - procedure Prune_Tree (Root : Node_Id); - -- Remove all code marked as ignored Ghost from the tree of denoted by - -- Root. - - ---------------- - -- Prune_Tree -- - ---------------- - - procedure Prune_Tree (Root : Node_Id) is - procedure Prune (N : Node_Id); - -- Remove a given node from the tree by rewriting it into null - - function Prune_Node (N : Node_Id) return Traverse_Result; - -- Determine whether node N denotes an ignored Ghost construct. If - -- this is the case, rewrite N as a null statement. See the body for - -- special cases. - - ----------- - -- Prune -- - ----------- - - procedure Prune (N : Node_Id) is - begin - -- Destroy any aspects that may be associated with the node - - if Permits_Aspect_Specifications (N) and then Has_Aspects (N) then - Remove_Aspects (N); - end if; - - Rewrite (N, Make_Null_Statement (Sloc (N))); - end Prune; - - ---------------- - -- Prune_Node -- - ---------------- - - function Prune_Node (N : Node_Id) return Traverse_Result is - Id : Entity_Id; - - begin - -- Do not prune compilation unit nodes because many mechanisms - -- depend on their presence. Note that context items are still - -- being processed. + procedure Remove_Ignored_Ghost_Node (N : Node_Id); + -- Eliminate ignored Ghost node N from the tree - if Nkind (N) = N_Compilation_Unit then - return OK; + ------------------------------- + -- Remove_Ignored_Ghost_Node -- + ------------------------------- - -- The node is either declared as ignored Ghost or is a byproduct - -- of expansion. Destroy it and stop the traversal on this branch. - - elsif Is_Ignored_Ghost_Node (N) then - Prune (N); - return Skip; - - -- Scoping constructs such as blocks, packages, subprograms and - -- bodies offer some flexibility with respect to pruning. - - elsif Nkind_In (N, N_Block_Statement, - N_Package_Body, - N_Package_Declaration, - N_Subprogram_Body, - N_Subprogram_Declaration) - then - if Nkind (N) = N_Block_Statement then - Id := Entity (Identifier (N)); - else - Id := Defining_Entity (N); - end if; - - -- The scoping construct contains both living and ignored Ghost - -- code, let the traversal prune all relevant nodes. + procedure Remove_Ignored_Ghost_Node (N : Node_Id) is + begin + -- The generation and processing of ignored Ghost nodes may cause the + -- same node to be saved multiple times. Reducing the number of saves + -- to one involves costly solutions such as a hash table or the use + -- of a flag shared by all nodes. To solve this problem, the removal + -- machinery allows for multiple saves, but does not eliminate a node + -- which has already been eliminated. - if Contains_Ignored_Ghost_Code (Id) then - return OK; + if Nkind (N) = N_Null_Statement then + null; - -- Otherwise the construct contains only living code and should - -- not be pruned. + -- Otherwise the ignored Ghost node must be eliminated - else - return Skip; - end if; + else + -- Only ignored Ghost nodes must be eliminated from the tree - -- Otherwise keep searching for ignored Ghost nodes + pragma Assert (Is_Ignored_Ghost_Node (N)); - else - return OK; - end if; - end Prune_Node; + -- Eliminate the node by rewriting it into null. Another option + -- is to remove it from the tree, however multiple corner cases + -- emerge which have be dealt individually. - procedure Prune_Nodes is new Traverse_Proc (Prune_Node); + Rewrite (N, Make_Null_Statement (Sloc (N))); - -- Start of processing for Prune_Tree + -- Eliminate any aspects hanging off the ignored Ghost node - begin - Prune_Nodes (Root); - end Prune_Tree; + Remove_Aspects (N); + end if; + end Remove_Ignored_Ghost_Node; -- Start of processing for Remove_Ignored_Ghost_Code begin - for Index in Ignored_Ghost_Units.First .. Ignored_Ghost_Units.Last loop - Prune_Tree (Ignored_Ghost_Units.Table (Index)); + for Index in Ignored_Ghost_Nodes.First .. Ignored_Ghost_Nodes.Last loop + Remove_Ignored_Ghost_Node (Ignored_Ghost_Nodes.Table (Index)); end loop; end Remove_Ignored_Ghost_Code; diff --git a/gcc/ada/ghost.ads b/gcc/ada/ghost.ads index ef95116..c079595 100644 --- a/gcc/ada/ghost.ads +++ b/gcc/ada/ghost.ads @@ -31,10 +31,6 @@ with Types; use Types; package Ghost is - procedure Add_Ignored_Ghost_Unit (Unit : Node_Id); - -- Add a single ignored Ghost compilation unit to the internal table for - -- post processing. - procedure Check_Ghost_Completion (Prev_Id : Entity_Id; Compl_Id : Entity_Id); diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 06b5536..4b8db7d 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -50,7 +50,7 @@ with Osint.C; use Osint.C; with Output; use Output; with Par_SCO; with Prepcomp; -with Repinfo; use Repinfo; +with Repinfo; with Restrict; with Rident; use Rident; with Rtsfind; @@ -467,6 +467,12 @@ procedure Gnat1drv is Ineffective_Inline_Warnings := True; + -- Do not issue warnings for possible propagation of exception. + -- GNATprove already issues messages about possible exceptions. + + No_Warn_On_Non_Local_Exception := True; + Warn_On_Non_Local_Exception := False; + -- Disable front-end optimizations, to keep the tree as close to the -- source code as possible, and also to avoid inconsistencies between -- trees when using different optimization switches. @@ -1442,7 +1448,9 @@ begin Exit_Program (Ecode); end if; - -- In -gnatc mode, we only do annotation if -gnatt or -gnatR is also set + -- In -gnatc mode we only do annotation if -gnatt or -gnatR is also set, + -- or if -gnatwz is enabled (default setting) and there is an unchecked + -- conversion that involves a type whose size is not statically known, -- as indicated by Back_Annotate_Rep_Info being set to True. -- We don't call for annotations on a subunit, because to process those @@ -1455,6 +1463,9 @@ begin -- representation information will be provided by the GNSA back end, not -- gigi. + -- A special back end is always called in CodePeer and GNATprove modes, + -- unless this is a subunit. + if Back_End_Mode = Declarations_Only and then (not (Back_Annotate_Rep_Info or Generate_SCIL or GNATprove_Mode) @@ -1468,7 +1479,11 @@ begin Tree_Dump; Tree_Gen; Namet.Finalize; - Check_Rep_Info; + + if not (Generate_SCIL or GNATprove_Mode) then + Check_Rep_Info; + end if; + return; end if; @@ -1551,7 +1566,7 @@ begin Errout.Finalize (Last_Call => True); Errout.Output_Messages; - List_Rep_Info (Ttypes.Bytes_Big_Endian); + Repinfo.List_Rep_Info (Ttypes.Bytes_Big_Endian); Inline.List_Inlining_Info; -- Only write the library if the backend did not generate any error diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 7647865..95e63b7 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , May 22, 2018 +GNAT Reference Manual , Jun 06, 2018 AdaCore @@ -1761,7 +1761,7 @@ documentation. Syntax: @example -pragma Assertion_Policy (CHECK | DISABLE | IGNORE); +pragma Assertion_Policy (CHECK | DISABLE | IGNORE | SUPPRESSIBLE); pragma Assertion_Policy ( ASSERTION_KIND => POLICY_IDENTIFIER diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 949551f..b5972bb 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , May 22, 2018 +GNAT User's Guide for Native Platforms , Jul 13, 2018 AdaCore @@ -349,7 +349,7 @@ The Ada to HTML Converter gnathtml GNAT and Program Execution * Running and Debugging Ada Programs:: -* Code Coverage and Profiling:: +* Profiling:: * Improving Performance:: * Overflow Check Handling in GNAT:: * Performing Dimensionality Analysis in GNAT:: @@ -379,16 +379,10 @@ Stack Traceback * Non-Symbolic Traceback:: * Symbolic Traceback:: -Code Coverage and Profiling +Profiling -* Code Coverage of Ada Programs with gcov:: * Profiling an Ada Program with gprof:: -Code Coverage of Ada Programs with gcov - -* Quick startup guide:: -* GNAT specifics:: - Profiling an Ada Program with gprof * Compilation for profiling:: @@ -804,7 +798,7 @@ GNAT tools: @ref{24,,Running and Debugging Ada Programs} @item -@ref{25,,Code Coverage and Profiling} +@ref{25,,Profiling} @item @ref{26,,Improving Performance} @@ -8163,9 +8157,9 @@ Do not look for library files in the system default directory. @item @code{--RTS=@emph{rts-path}} -Specifies the default location of the runtime library. GNAT looks for the -runtime -in the following directories, and stops as soon as a valid runtime is found +Specifies the default location of the run-time library. GNAT looks for the +run-time +in the following directories, and stops as soon as a valid run-time is found (@code{adainclude} or @code{ada_source_path}, and @code{adalib} or @code{ada_object_path} present): @@ -9176,7 +9170,7 @@ Detect_Aliasing (Obj, Self (Obj)); @end example In the example above, the first call to @code{Detect_Aliasing} fails with a -@code{Program_Error} at runtime because the actuals for @code{Val_1} and +@code{Program_Error} at run time because the actuals for @code{Val_1} and @code{Val_2} denote the same object. The second call executes without raising an exception because @code{Self(Obj)} produces an anonymous object which does not share the memory location of @code{Obj}. @@ -9583,14 +9577,12 @@ Externals names are folded to all uppercase. @item @code{-gnatg} -Internal GNAT implementation mode. This should not be used for -applications programs, it is intended only for use by the compiler -and its run-time library. For documentation, see the GNAT sources. -Note that @code{-gnatg} implies -@code{-gnatw.ge} and -@code{-gnatyg} -so that all standard warnings and all standard style options are turned on. -All warnings and style messages are treated as errors. +Internal GNAT implementation mode. This should not be used for applications +programs, it is intended only for use by the compiler and its run-time +library. For documentation, see the GNAT sources. Note that @code{-gnatg} +implies @code{-gnatw.ge} and @code{-gnatyg} so that all standard +warnings and all standard style options are turned on. All warnings and style +messages are treated as errors. @end table @geindex -gnatG[nn] (gcc) @@ -9613,6 +9605,17 @@ List generated expanded code in source form. Output usage information. The output is written to @code{stdout}. @end table +@geindex -gnatH (gcc) + + +@table @asis + +@item @code{-gnatH} + +Legacy elaboration-checking mode enabled. When this switch is in effect, the +pre-18.x access-before-elaboration model becomes the de facto model. +@end table + @geindex -gnati (gcc) @@ -9660,6 +9663,56 @@ from the tree and ignored. This means that the tool will not see them. Reformat error messages to fit on @code{nn} character lines @end table +@geindex -gnatJ (gcc) + + +@table @asis + +@item @code{-gnatJ} + +Permissive elaboration-checking mode enabled. When this switch is in effect, +the post-18.x access-before-elaboration model ignores potential issues with: + + +@itemize - + +@item +Accept statements + +@item +Activations of tasks defined in instances + +@item +Assertion pragmas + +@item +Calls from within an instance to its enclosing context + +@item +Calls through generic formal parameters + +@item +Calls to subprograms defined in instances + +@item +Entry calls + +@item +Indirect calls using 'Access + +@item +Requeue statements + +@item +Select statements + +@item +Synchronous task suspension +@end itemize + +and does not emit compile-time diagnostics or run-time checks. +@end table + @geindex -gnatk (gcc) @@ -10201,7 +10254,7 @@ exit status. @item @code{--RTS=@emph{rts-path}} -Specifies the default location of the runtime library. Same meaning as the +Specifies the default location of the run-time library. Same meaning as the equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}). @end table @@ -13987,7 +14040,7 @@ if checks are suppressed. In particular, if the compiler can prove that a certain check will necessarily fail, it will generate code to do an unconditional 'raise', even if checks are suppressed. The compiler warns in this case. Another case in which checks may not be -eliminated is when they are embedded in certain run time routines such +eliminated is when they are embedded in certain run-time routines such as math library routines. Of course, run-time checks are omitted whenever the compiler can prove @@ -15095,7 +15148,7 @@ speed up compilation, but means that these tools cannot be used. @subsection Exception Handling Control -GNAT uses two methods for handling exceptions at run-time. The +GNAT uses two methods for handling exceptions at run time. The @code{setjmp/longjmp} method saves the context when entering a frame with an exception handler. Then when an exception is raised, the context can be restored immediately, without the @@ -15712,7 +15765,7 @@ Do not look for library files in the system default directory. @item @code{--RTS=@emph{rts-path}} -Specifies the default location of the runtime library. Same meaning as the +Specifies the default location of the run-time library. Same meaning as the equivalent @code{gnatmake} flag (@ref{dc,,Switches for gnatmake}). @geindex -o (gnatbind) @@ -15829,13 +15882,13 @@ then the default is @code{in} (invalid values). @item @code{-static} -Link against a static GNAT run time. +Link against a static GNAT run-time. @geindex -shared (gnatbind) @item @code{-shared} -Link against a shared GNAT run time when available. +Link against a shared GNAT run-time when available. @geindex -t (gnatbind) @@ -15854,7 +15907,7 @@ does support some general notion of round-robin scheduling, then any nonzero value will activate round-robin scheduling. A value of zero is treated specially. It turns off time -slicing, and in addition, indicates to the tasking run time that the +slicing, and in addition, indicates to the tasking run-time that the semantics should match as closely as possible the Annex D requirements of the Ada RM, and in particular sets the default scheduling policy to @code{FIFO_Within_Priorities}. @@ -16372,7 +16425,7 @@ The output is an Ada unit in source form that can be compiled with GNAT. This compilation occurs automatically as part of the @code{gnatlink} processing. -Currently the GNAT run time requires a FPU using 80 bits mode +Currently the GNAT run-time requires a FPU using 80 bits mode precision. Under targets where this is not the default it is required to call GNAT.Float_Control.Reset before using floating point numbers (this include float computation, float input and output) in the Ada code. A @@ -16497,7 +16550,7 @@ of GNAT). @item The content of the @code{ada_object_path} file which is part of the GNAT installation tree and is used to store standard libraries such as the -GNAT Run Time Library (RTL) unless the switch @code{-nostdlib} is +GNAT Run-Time Library (RTL) unless the switch @code{-nostdlib} is specified. See @ref{87,,Installing a library} @end itemize @@ -18955,27 +19008,27 @@ This chapter covers several topics: @ref{167,,Running and Debugging Ada Programs} @item -@ref{168,,Code Coverage and Profiling} +@ref{25,,Profiling} @item -@ref{169,,Improving Performance} +@ref{168,,Improving Performance} @item -@ref{16a,,Overflow Check Handling in GNAT} +@ref{169,,Overflow Check Handling in GNAT} @item -@ref{16b,,Performing Dimensionality Analysis in GNAT} +@ref{16a,,Performing Dimensionality Analysis in GNAT} @item -@ref{16c,,Stack Related Facilities} +@ref{16b,,Stack Related Facilities} @item -@ref{16d,,Memory Management Issues} +@ref{16c,,Memory Management Issues} @end itemize @menu * Running and Debugging Ada Programs:: -* Code Coverage and Profiling:: +* Profiling:: * Improving Performance:: * Overflow Check Handling in GNAT:: * Performing Dimensionality Analysis in GNAT:: @@ -18984,7 +19037,7 @@ This chapter covers several topics: @end menu -@node Running and Debugging Ada Programs,Code Coverage and Profiling,,GNAT and Program Execution +@node Running and Debugging Ada Programs,Profiling,,GNAT and Program Execution @anchor{gnat_ugn/gnat_and_program_execution id2}@anchor{167}@anchor{gnat_ugn/gnat_and_program_execution running-and-debugging-ada-programs}@anchor{24} @section Running and Debugging Ada Programs @@ -19039,7 +19092,7 @@ the incorrect user program. @end menu @node The GNAT Debugger GDB,Running GDB,,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{16e}@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{16f} +@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{16d}@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{16e} @subsection The GNAT Debugger GDB @@ -19096,7 +19149,7 @@ the debugging information and can respond to user commands to inspect variables, and more generally to report on the state of execution. @node Running GDB,Introduction to GDB Commands,The GNAT Debugger GDB,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{170}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{171} +@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{16f}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{170} @subsection Running GDB @@ -19123,7 +19176,7 @@ exactly as if the debugger were not present. The following section describes some of the additional commands that can be given to @code{GDB}. @node Introduction to GDB Commands,Using Ada Expressions,Running GDB,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{172}@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{173} +@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{171}@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{172} @subsection Introduction to GDB Commands @@ -19331,7 +19384,7 @@ Note that most commands can be abbreviated (for example, c for continue, bt for backtrace). @node Using Ada Expressions,Calling User-Defined Subprograms,Introduction to GDB Commands,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{174}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{175} +@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{173}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{174} @subsection Using Ada Expressions @@ -19369,7 +19422,7 @@ their packages, regardless of context. Where this causes ambiguity, For details on the supported Ada syntax, see @cite{Debugging with GDB}. @node Calling User-Defined Subprograms,Using the next Command in a Function,Using Ada Expressions,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{176}@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{177} +@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{175}@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{176} @subsection Calling User-Defined Subprograms @@ -19428,7 +19481,7 @@ elements directly from GDB, you can write a callable procedure that prints the elements in the desired format. @node Using the next Command in a Function,Stopping When Ada Exceptions Are Raised,Calling User-Defined Subprograms,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{178}@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{179} +@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{177}@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{178} @subsection Using the @emph{next} Command in a Function @@ -19451,7 +19504,7 @@ The value returned is always that from the first return statement that was stepped through. @node Stopping When Ada Exceptions Are Raised,Ada Tasks,Using the next Command in a Function,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{17a}@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{17b} +@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{179}@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{17a} @subsection Stopping When Ada Exceptions Are Raised @@ -19508,7 +19561,7 @@ argument, prints out only those exceptions whose name matches @emph{regexp}. @geindex Tasks (in gdb) @node Ada Tasks,Debugging Generic Units,Stopping When Ada Exceptions Are Raised,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{17c}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{17d} +@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{17b}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{17c} @subsection Ada Tasks @@ -19595,7 +19648,7 @@ see @cite{Debugging with GDB}. @geindex Generics @node Debugging Generic Units,Remote Debugging with gdbserver,Ada Tasks,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{17e}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{17f} +@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{17d}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{17e} @subsection Debugging Generic Units @@ -19654,7 +19707,7 @@ other units. @geindex Remote Debugging with gdbserver @node Remote Debugging with gdbserver,GNAT Abnormal Termination or Failure to Terminate,Debugging Generic Units,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{180}@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{181} +@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{17f}@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{180} @subsection Remote Debugging with gdbserver @@ -19712,7 +19765,7 @@ GNAT provides support for gdbserver on x86-linux, x86-windows and x86_64-linux. @geindex Abnormal Termination or Failure to Terminate @node GNAT Abnormal Termination or Failure to Terminate,Naming Conventions for GNAT Source Files,Remote Debugging with gdbserver,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{182}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{183} +@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{181}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{182} @subsection GNAT Abnormal Termination or Failure to Terminate @@ -19767,7 +19820,7 @@ Finally, you can start @code{gdb} directly on the @code{gnat1} executable. @code{gnat1} is the front-end of GNAT, and can be run independently (normally it is just called from @code{gcc}). You can use @code{gdb} on @code{gnat1} as you -would on a C program (but @ref{16e,,The GNAT Debugger GDB} for caveats). The +would on a C program (but @ref{16d,,The GNAT Debugger GDB} for caveats). The @code{where} command is the first line of attack; the variable @code{lineno} (seen by @code{print lineno}), used by the second phase of @code{gnat1} and by the @code{gcc} backend, indicates the source line at @@ -19776,7 +19829,7 @@ the source file. @end itemize @node Naming Conventions for GNAT Source Files,Getting Internal Debugging Information,GNAT Abnormal Termination or Failure to Terminate,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{184}@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{185} +@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{183}@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{184} @subsection Naming Conventions for GNAT Source Files @@ -19857,7 +19910,7 @@ the other @code{.c} files are modifications of common @code{gcc} files. @end itemize @node Getting Internal Debugging Information,Stack Traceback,Naming Conventions for GNAT Source Files,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{186}@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{187} +@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{185}@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{186} @subsection Getting Internal Debugging Information @@ -19885,7 +19938,7 @@ are replaced with run-time calls. @geindex stack unwinding @node Stack Traceback,Pretty-Printers for the GNAT runtime,Getting Internal Debugging Information,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{188}@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{189} +@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{187}@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{188} @subsection Stack Traceback @@ -19914,7 +19967,7 @@ is enabled, and no exception is raised during program execution. @end menu @node Non-Symbolic Traceback,Symbolic Traceback,,Stack Traceback -@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{18a}@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{18b} +@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{189}@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{18a} @subsubsection Non-Symbolic Traceback @@ -20199,7 +20252,7 @@ need to be specified in C format, with a leading '0x'). @geindex symbolic @node Symbolic Traceback,,Non-Symbolic Traceback,Stack Traceback -@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{18c}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{18d} +@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{18b}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{18c} @subsubsection Symbolic Traceback @@ -20327,7 +20380,7 @@ which will also be printed if an unhandled exception terminates the program. @node Pretty-Printers for the GNAT runtime,,Stack Traceback,Running and Debugging Ada Programs -@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{18e}@anchor{gnat_ugn/gnat_and_program_execution pretty-printers-for-the-gnat-runtime}@anchor{18f} +@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{18d}@anchor{gnat_ugn/gnat_and_program_execution pretty-printers-for-the-gnat-runtime}@anchor{18e} @subsection Pretty-Printers for the GNAT runtime @@ -20431,134 +20484,27 @@ $1 = ( Finer control of pretty-printers is also possible: see GDB's online documentation@footnote{http://docs.adacore.com/gdb-docs/html/gdb.html#Pretty_002dPrinter-Commands} for more information. -@geindex Code Coverage - @geindex Profiling -@node Code Coverage and Profiling,Improving Performance,Running and Debugging Ada Programs,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{168}@anchor{gnat_ugn/gnat_and_program_execution code-coverage-and-profiling}@anchor{25} -@section Code Coverage and Profiling - +@node Profiling,Improving Performance,Running and Debugging Ada Programs,GNAT and Program Execution +@anchor{gnat_ugn/gnat_and_program_execution profiling}@anchor{25}@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{18f} +@section Profiling -This section describes how to use the @code{gcov} coverage testing tool and -the @code{gprof} profiler tool on Ada programs. -@geindex gcov +This section describes how to use the the @code{gprof} profiler tool on Ada +programs. -@menu -* Code Coverage of Ada Programs with gcov:: -* Profiling an Ada Program with gprof:: - -@end menu - -@node Code Coverage of Ada Programs with gcov,Profiling an Ada Program with gprof,,Code Coverage and Profiling -@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{190}@anchor{gnat_ugn/gnat_and_program_execution code-coverage-of-ada-programs-with-gcov}@anchor{191} -@subsection Code Coverage of Ada Programs with gcov - - -@code{gcov} is a test coverage program: it analyzes the execution of a given -program on selected tests, to help you determine the portions of the program -that are still untested. - -@code{gcov} is part of the GCC suite, and is described in detail in the GCC -User's Guide. You can refer to this documentation for a more complete -description. +@geindex gprof -This chapter provides a quick startup guide, and -details some GNAT-specific features. +@geindex Profiling @menu -* Quick startup guide:: -* GNAT specifics:: +* Profiling an Ada Program with gprof:: @end menu -@node Quick startup guide,GNAT specifics,,Code Coverage of Ada Programs with gcov -@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{192}@anchor{gnat_ugn/gnat_and_program_execution quick-startup-guide}@anchor{193} -@subsubsection Quick startup guide - - -In order to perform coverage analysis of a program using @code{gcov}, several -steps are needed: - - -@enumerate - -@item -Instrument the code during the compilation process, - -@item -Execute the instrumented program, and - -@item -Invoke the @code{gcov} tool to generate the coverage results. -@end enumerate - -@geindex -fprofile-arcs (gcc) - -@geindex -ftest-coverage (gcc - -@geindex -fprofile-arcs (gnatbind) - -The code instrumentation needed by gcov is created at the object level. -The source code is not modified in any way, because the instrumentation code is -inserted by gcc during the compilation process. To compile your code with code -coverage activated, you need to recompile your whole project using the -switches -@code{-fprofile-arcs} and @code{-ftest-coverage}, and link it using -@code{-fprofile-arcs}. - -@quotation - -@example -$ gnatmake -P my_project.gpr -f -cargs -fprofile-arcs -ftest-coverage \\ - -largs -fprofile-arcs -@end example -@end quotation - -This compilation process will create @code{.gcno} files together with -the usual object files. - -Once the program is compiled with coverage instrumentation, you can -run it as many times as needed -- on portions of a test suite for -example. The first execution will produce @code{.gcda} files at the -same location as the @code{.gcno} files. Subsequent executions -will update those files, so that a cumulative result of the covered -portions of the program is generated. - -Finally, you need to call the @code{gcov} tool. The different options of -@code{gcov} are described in the GCC User's Guide, section @emph{Invoking gcov}. - -This will create annotated source files with a @code{.gcov} extension: -@code{my_main.adb} file will be analyzed in @code{my_main.adb.gcov}. - -@node GNAT specifics,,Quick startup guide,Code Coverage of Ada Programs with gcov -@anchor{gnat_ugn/gnat_and_program_execution gnat-specifics}@anchor{194}@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{195} -@subsubsection GNAT specifics - - -Because of Ada semantics, portions of the source code may be shared among -several object files. This is the case for example when generics are -involved, when inlining is active or when declarations generate initialisation -calls. In order to take -into account this shared code, you need to call @code{gcov} on all -source files of the tested program at once. - -The list of source files might exceed the system's maximum command line -length. In order to bypass this limitation, a new mechanism has been -implemented in @code{gcov}: you can now list all your project's files into a -text file, and provide this file to gcov as a parameter, preceded by a @code{@@} -(e.g. @code{gcov @@mysrclist.txt}). - -Note that on AIX compiling a static library with @code{-fprofile-arcs} is -not supported as there can be unresolved symbols during the final link. - -@geindex gprof - -@geindex Profiling - -@node Profiling an Ada Program with gprof,,Code Coverage of Ada Programs with gcov,Code Coverage and Profiling -@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{196}@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{197} +@node Profiling an Ada Program with gprof,,,Profiling +@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{190}@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{191} @subsection Profiling an Ada Program with gprof @@ -20580,9 +20526,6 @@ It is currently supported on the following platforms linux x86/x86_64 @item -solaris sparc/sparc64/x86 - -@item windows x86 @end itemize @@ -20615,7 +20558,7 @@ to interpret the results. @end menu @node Compilation for profiling,Program execution,,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{198}@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{199} +@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{192}@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{193} @subsubsection Compilation for profiling @@ -20643,7 +20586,7 @@ be profiled; if you need to profile your whole project, use the @code{-f} gnatmake switch to force full recompilation. @node Program execution,Running gprof,Compilation for profiling,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{19a}@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{19b} +@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{194}@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{195} @subsubsection Program execution @@ -20658,7 +20601,7 @@ generated in the directory where the program was launched from. If this file already exists, it will be overwritten. @node Running gprof,Interpretation of profiling results,Program execution,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{19c}@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{19d} +@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{196}@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{197} @subsubsection Running gprof @@ -20771,7 +20714,7 @@ may be given; only one @code{function_name} may be indicated with each @end table @node Interpretation of profiling results,,Running gprof,Profiling an Ada Program with gprof -@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{19e}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{19f} +@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{198}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{199} @subsubsection Interpretation of profiling results @@ -20787,8 +20730,8 @@ The call graph shows, for each subprogram, the subprograms that call it, and the subprograms that it calls. It also provides an estimate of the time spent in each of those callers/called subprograms. -@node Improving Performance,Overflow Check Handling in GNAT,Code Coverage and Profiling,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{169}@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{26} +@node Improving Performance,Overflow Check Handling in GNAT,Profiling,GNAT and Program Execution +@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{26}@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{168} @section Improving Performance @@ -20810,7 +20753,7 @@ which can reduce the size of program executables. @end menu @node Performance Considerations,Text_IO Suggestions,,Improving Performance -@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{1a0}@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{1a1} +@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{19a}@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{19b} @subsection Performance Considerations @@ -20871,7 +20814,7 @@ some guidelines on debugging optimized code. @end menu @node Controlling Run-Time Checks,Use of Restrictions,,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{1a2}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{1a3} +@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{19c}@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{19d} @subsubsection Controlling Run-Time Checks @@ -20923,7 +20866,7 @@ remove checks) or @code{pragma Unsuppress} (to add back suppressed checks) in the program source. @node Use of Restrictions,Optimization Levels,Controlling Run-Time Checks,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{1a4}@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{1a5} +@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{19e}@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{19f} @subsubsection Use of Restrictions @@ -20958,7 +20901,7 @@ that this also means that you can write code without worrying about the possibility of an immediate abort at any point. @node Optimization Levels,Debugging Optimized Code,Use of Restrictions,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{1a6}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{fc} +@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{1a0}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{fc} @subsubsection Optimization Levels @@ -21082,7 +21025,7 @@ since it often results in larger executables which may run more slowly. See further discussion of this point in @ref{10f,,Inlining of Subprograms}. @node Debugging Optimized Code,Inlining of Subprograms,Optimization Levels,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{1a7}@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{1a8} +@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{1a1}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{1a2} @subsubsection Debugging Optimized Code @@ -21210,7 +21153,7 @@ on the resulting executable, which removes both debugging information and global symbols. @node Inlining of Subprograms,Floating_Point_Operations,Debugging Optimized Code,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{1a9}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{10f} +@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{1a3}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{10f} @subsubsection Inlining of Subprograms @@ -21349,7 +21292,7 @@ indeed you should use @code{-O3} only if tests show that it actually improves performance for your program. @node Floating_Point_Operations,Vectorization of loops,Inlining of Subprograms,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{1aa}@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{1ab} +@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{1a4}@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{1a5} @subsubsection Floating_Point_Operations @@ -21397,7 +21340,7 @@ so it is permissible to mix units compiled with and without these switches. @node Vectorization of loops,Other Optimization Switches,Floating_Point_Operations,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{1ac}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{1ad} +@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{1a6}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{1a7} @subsubsection Vectorization of loops @@ -21548,7 +21491,7 @@ placed immediately within the loop will tell the compiler that it can safely omit the non-vectorized version of the loop as well as the run-time test. @node Other Optimization Switches,Optimization and Strict Aliasing,Vectorization of loops,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{1ae}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{1af} +@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{1a8}@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{1a9} @subsubsection Other Optimization Switches @@ -21565,7 +21508,7 @@ the @emph{Submodel Options} section in the @emph{Hardware Models and Configurati chapter of @cite{Using the GNU Compiler Collection (GCC)}. @node Optimization and Strict Aliasing,Aliased Variables and Optimization,Other Optimization Switches,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{f3}@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{1b0} +@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{f3}@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{1aa} @subsubsection Optimization and Strict Aliasing @@ -21805,7 +21748,7 @@ review any uses of unchecked conversion of access types, particularly if you are getting the warnings described above. @node Aliased Variables and Optimization,Atomic Variables and Optimization,Optimization and Strict Aliasing,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{1b1}@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{1b2} +@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{1ab}@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{1ac} @subsubsection Aliased Variables and Optimization @@ -21863,7 +21806,7 @@ This means that the above example will in fact "work" reliably, that is, it will produce the expected results. @node Atomic Variables and Optimization,Passive Task Optimization,Aliased Variables and Optimization,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{1b3}@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{1b4} +@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{1ad}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{1ae} @subsubsection Atomic Variables and Optimization @@ -21944,7 +21887,7 @@ such synchronization code is not required, it may be useful to disable it. @node Passive Task Optimization,,Atomic Variables and Optimization,Performance Considerations -@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{1b5}@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{1b6} +@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{1af}@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{1b0} @subsubsection Passive Task Optimization @@ -21989,7 +21932,7 @@ that typically clients of the tasks who call entries, will not have to be modified, only the task definition itself. @node Text_IO Suggestions,Reducing Size of Executables with Unused Subprogram/Data Elimination,Performance Considerations,Improving Performance -@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{1b7}@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{1b8} +@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{1b1}@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{1b2} @subsection @code{Text_IO} Suggestions @@ -22012,7 +21955,7 @@ of the standard output file, or change the standard output file to be buffered using @code{Interfaces.C_Streams.setvbuf}. @node Reducing Size of Executables with Unused Subprogram/Data Elimination,,Text_IO Suggestions,Improving Performance -@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{1b9}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{1ba} +@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{1b3}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{1b4} @subsection Reducing Size of Executables with Unused Subprogram/Data Elimination @@ -22029,7 +21972,7 @@ your executable just by setting options at compilation time. @end menu @node About unused subprogram/data elimination,Compilation options,,Reducing Size of Executables with Unused Subprogram/Data Elimination -@anchor{gnat_ugn/gnat_and_program_execution id45}@anchor{1bb}@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{1bc} +@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{1b5}@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{1b6} @subsubsection About unused subprogram/data elimination @@ -22045,7 +21988,7 @@ architecture and on all cross platforms using the ELF binary file format. In both cases GNU binutils version 2.16 or later are required to enable it. @node Compilation options,Example of unused subprogram/data elimination,About unused subprogram/data elimination,Reducing Size of Executables with Unused Subprogram/Data Elimination -@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{1bd}@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{1be} +@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{1b7}@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{1b8} @subsubsection Compilation options @@ -22084,7 +22027,7 @@ The GNAT static library is now compiled with -ffunction-sections and and data of the GNAT library from your executable. @node Example of unused subprogram/data elimination,,Compilation options,Reducing Size of Executables with Unused Subprogram/Data Elimination -@anchor{gnat_ugn/gnat_and_program_execution id47}@anchor{1bf}@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{1c0} +@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{1b9}@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{1ba} @subsubsection Example of unused subprogram/data elimination @@ -22155,7 +22098,7 @@ appropriate options. @node Overflow Check Handling in GNAT,Performing Dimensionality Analysis in GNAT,Improving Performance,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id53}@anchor{16a}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{27} +@anchor{gnat_ugn/gnat_and_program_execution id50}@anchor{169}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{27} @section Overflow Check Handling in GNAT @@ -22171,7 +22114,7 @@ This section explains how to control the handling of overflow checks. @end menu @node Background,Management of Overflows in GNAT,,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{1c1}@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{1c2} +@anchor{gnat_ugn/gnat_and_program_execution id51}@anchor{1bb}@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{1bc} @subsection Background @@ -22297,7 +22240,7 @@ exception raised because of the intermediate overflow (and we really would prefer this precondition to be considered True at run time). @node Management of Overflows in GNAT,Specifying the Desired Mode,Background,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1c3}@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{1c4} +@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{1bd}@anchor{gnat_ugn/gnat_and_program_execution id52}@anchor{1be} @subsection Management of Overflows in GNAT @@ -22411,7 +22354,7 @@ out in the normal manner (with infinite values always failing all range checks). @node Specifying the Desired Mode,Default Settings,Management of Overflows in GNAT,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{1c5}@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{f8} +@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{f8}@anchor{gnat_ugn/gnat_and_program_execution id53}@anchor{1bf} @subsection Specifying the Desired Mode @@ -22535,7 +22478,7 @@ causing all intermediate operations to be computed using the base type (@code{STRICT} mode). @node Default Settings,Implementation Notes,Specifying the Desired Mode,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{1c6}@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1c7} +@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{1c0}@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1c1} @subsection Default Settings @@ -22582,7 +22525,7 @@ checking, but it has no effect on the method used for computing intermediate results. @node Implementation Notes,,Default Settings,Overflow Check Handling in GNAT -@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1c8}@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{1c9} +@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1c2}@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1c3} @subsection Implementation Notes @@ -22630,7 +22573,7 @@ platforms for which @code{Long_Long_Integer} is 64-bits (nearly all GNAT platforms). @node Performing Dimensionality Analysis in GNAT,Stack Related Facilities,Overflow Check Handling in GNAT,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{28}@anchor{gnat_ugn/gnat_and_program_execution id59}@anchor{16b} +@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{16a}@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{28} @section Performing Dimensionality Analysis in GNAT @@ -23003,7 +22946,7 @@ passing (the dimension vector for the actual parameter must be equal to the dimension vector for the formal parameter). @node Stack Related Facilities,Memory Management Issues,Performing Dimensionality Analysis in GNAT,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{29}@anchor{gnat_ugn/gnat_and_program_execution id60}@anchor{16c} +@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{16b}@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{29} @section Stack Related Facilities @@ -23019,7 +22962,7 @@ particular, it deals with dynamic and static stack usage measurements. @end menu @node Stack Overflow Checking,Static Stack Usage Analysis,,Stack Related Facilities -@anchor{gnat_ugn/gnat_and_program_execution id61}@anchor{1ca}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{f4} +@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{1c4}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{f4} @subsection Stack Overflow Checking @@ -23064,7 +23007,7 @@ Consequently, to modify the size of the environment task please refer to your operating system documentation. @node Static Stack Usage Analysis,Dynamic Stack Usage Analysis,Stack Overflow Checking,Stack Related Facilities -@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{f5}@anchor{gnat_ugn/gnat_and_program_execution id62}@anchor{1cb} +@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{f5}@anchor{gnat_ugn/gnat_and_program_execution id59}@anchor{1c5} @subsection Static Stack Usage Analysis @@ -23113,7 +23056,7 @@ subprogram whose stack usage might be larger than the specified amount of bytes. The wording is in keeping with the qualifier documented above. @node Dynamic Stack Usage Analysis,,Static Stack Usage Analysis,Stack Related Facilities -@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{121}@anchor{gnat_ugn/gnat_and_program_execution id63}@anchor{1cc} +@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{121}@anchor{gnat_ugn/gnat_and_program_execution id60}@anchor{1c6} @subsection Dynamic Stack Usage Analysis @@ -23192,7 +23135,7 @@ The package @code{GNAT.Task_Stack_Usage} provides facilities to get stack-usage reports at run time. See its body for the details. @node Memory Management Issues,,Stack Related Facilities,GNAT and Program Execution -@anchor{gnat_ugn/gnat_and_program_execution id64}@anchor{16d}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{2a} +@anchor{gnat_ugn/gnat_and_program_execution id61}@anchor{16c}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{2a} @section Memory Management Issues @@ -23208,7 +23151,7 @@ incorrect uses of access values (including 'dangling references'). @end menu @node Some Useful Memory Pools,The GNAT Debug Pool Facility,,Memory Management Issues -@anchor{gnat_ugn/gnat_and_program_execution id65}@anchor{1cd}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{1ce} +@anchor{gnat_ugn/gnat_and_program_execution id62}@anchor{1c7}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{1c8} @subsection Some Useful Memory Pools @@ -23289,7 +23232,7 @@ for T1'Storage_Size use 10_000; @end quotation @node The GNAT Debug Pool Facility,,Some Useful Memory Pools,Memory Management Issues -@anchor{gnat_ugn/gnat_and_program_execution id66}@anchor{1cf}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{1d0} +@anchor{gnat_ugn/gnat_and_program_execution id63}@anchor{1c9}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{1ca} @subsection The GNAT Debug Pool Facility @@ -23452,7 +23395,7 @@ Debug Pool info: @c -- E.g. Ada |nbsp| 95 @node Platform-Specific Information,Example of Binder Output File,GNAT and Program Execution,Top -@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{d}@anchor{gnat_ugn/platform_specific_information doc}@anchor{1d1}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1d2} +@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{d}@anchor{gnat_ugn/platform_specific_information doc}@anchor{1cb}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1cc} @chapter Platform-Specific Information @@ -23470,7 +23413,7 @@ topics related to the GNAT implementation on Windows and Mac OS. @end menu @node Run-Time Libraries,Specifying a Run-Time Library,,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information id2}@anchor{1d3}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{2b} +@anchor{gnat_ugn/platform_specific_information id2}@anchor{1cd}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{2b} @section Run-Time Libraries @@ -23531,7 +23474,7 @@ information about several specific platforms. @end menu @node Summary of Run-Time Configurations,,,Run-Time Libraries -@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1d4}@anchor{gnat_ugn/platform_specific_information id3}@anchor{1d5} +@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1ce}@anchor{gnat_ugn/platform_specific_information id3}@anchor{1cf} @subsection Summary of Run-Time Configurations @@ -23631,7 +23574,7 @@ ZCX @node Specifying a Run-Time Library,GNU/Linux Topics,Run-Time Libraries,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1d6}@anchor{gnat_ugn/platform_specific_information id4}@anchor{1d7} +@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1d0}@anchor{gnat_ugn/platform_specific_information id4}@anchor{1d1} @section Specifying a Run-Time Library @@ -23718,7 +23661,7 @@ Alternatively, you can specify @code{rts-sjlj/adainclude} in the file Selecting another run-time library temporarily can be achieved by using the @code{--RTS} switch, e.g., @code{--RTS=sjlj} -@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy}@anchor{1d8} +@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy}@anchor{1d2} @geindex SCHED_FIFO scheduling policy @geindex SCHED_RR scheduling policy @@ -23731,7 +23674,7 @@ achieved by using the @code{--RTS} switch, e.g., @code{--RTS=sjlj} @end menu @node Choosing the Scheduling Policy,,,Specifying a Run-Time Library -@anchor{gnat_ugn/platform_specific_information id5}@anchor{1d9} +@anchor{gnat_ugn/platform_specific_information id5}@anchor{1d3} @subsection Choosing the Scheduling Policy @@ -23790,7 +23733,7 @@ Program_Error. @geindex GNU/Linux @node GNU/Linux Topics,Microsoft Windows Topics,Specifying a Run-Time Library,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information id6}@anchor{1da}@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1db} +@anchor{gnat_ugn/platform_specific_information id6}@anchor{1d4}@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1d5} @section GNU/Linux Topics @@ -23802,7 +23745,7 @@ This section describes topics that are specific to GNU/Linux platforms. @end menu @node Required Packages on GNU/Linux,,,GNU/Linux Topics -@anchor{gnat_ugn/platform_specific_information id7}@anchor{1dc}@anchor{gnat_ugn/platform_specific_information required-packages-on-gnu-linux}@anchor{1dd} +@anchor{gnat_ugn/platform_specific_information id7}@anchor{1d6}@anchor{gnat_ugn/platform_specific_information required-packages-on-gnu-linux}@anchor{1d7} @subsection Required Packages on GNU/Linux @@ -23838,7 +23781,7 @@ for those packages. @geindex Windows @node Microsoft Windows Topics,Mac OS Topics,GNU/Linux Topics,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{2c}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1de} +@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{2c}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1d8} @section Microsoft Windows Topics @@ -23861,7 +23804,7 @@ platforms. @end menu @node Using GNAT on Windows,Using a network installation of GNAT,,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1df}@anchor{gnat_ugn/platform_specific_information id9}@anchor{1e0} +@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1d9}@anchor{gnat_ugn/platform_specific_information id9}@anchor{1da} @subsection Using GNAT on Windows @@ -23938,7 +23881,7 @@ uninstall or integrate different GNAT products. @end itemize @node Using a network installation of GNAT,CONSOLE and WINDOWS subsystems,Using GNAT on Windows,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id10}@anchor{1e1}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{1e2} +@anchor{gnat_ugn/platform_specific_information id10}@anchor{1db}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{1dc} @subsection Using a network installation of GNAT @@ -23965,7 +23908,7 @@ transfer of large amounts of data across the network and will likely cause serious performance penalty. @node CONSOLE and WINDOWS subsystems,Temporary Files,Using a network installation of GNAT,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id11}@anchor{1e3}@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1e4} +@anchor{gnat_ugn/platform_specific_information id11}@anchor{1dd}@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1de} @subsection CONSOLE and WINDOWS subsystems @@ -23990,7 +23933,7 @@ $ gnatmake winprog -largs -mwindows @end quotation @node Temporary Files,Disabling Command Line Argument Expansion,CONSOLE and WINDOWS subsystems,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id12}@anchor{1e5}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{1e6} +@anchor{gnat_ugn/platform_specific_information id12}@anchor{1df}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{1e0} @subsection Temporary Files @@ -24029,7 +23972,7 @@ environments where you may not have write access to some directories. @node Disabling Command Line Argument Expansion,Mixed-Language Programming on Windows,Temporary Files,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1e7} +@anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1e1} @subsection Disabling Command Line Argument Expansion @@ -24100,7 +24043,7 @@ Ada.Command_Line.Argument (1) -> "'*.txt'" @end example @node Mixed-Language Programming on Windows,Windows Specific Add-Ons,Disabling Command Line Argument Expansion,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id13}@anchor{1e8}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1e9} +@anchor{gnat_ugn/platform_specific_information id13}@anchor{1e2}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1e3} @subsection Mixed-Language Programming on Windows @@ -24122,12 +24065,12 @@ to use the Microsoft tools for your C++ code, you have two choices: Encapsulate your C++ code in a DLL to be linked with your Ada application. In this case, use the Microsoft or whatever environment to build the DLL and use GNAT to build your executable -(@ref{1ea,,Using DLLs with GNAT}). +(@ref{1e4,,Using DLLs with GNAT}). @item Or you can encapsulate your Ada code in a DLL to be linked with the other part of your application. In this case, use GNAT to build the DLL -(@ref{1eb,,Building DLLs with GNAT Project files}) and use the Microsoft +(@ref{1e5,,Building DLLs with GNAT Project files}) and use the Microsoft or whatever environment to build your executable. @end itemize @@ -24184,7 +24127,7 @@ native SEH support is used. @end menu @node Windows Calling Conventions,Introduction to Dynamic Link Libraries DLLs,,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1ec}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1ed} +@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1e6}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1e7} @subsubsection Windows Calling Conventions @@ -24229,7 +24172,7 @@ are available for Windows: @end menu @node C Calling Convention,Stdcall Calling Convention,,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1ee}@anchor{gnat_ugn/platform_specific_information id15}@anchor{1ef} +@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1e8}@anchor{gnat_ugn/platform_specific_information id15}@anchor{1e9} @subsubsection @code{C} Calling Convention @@ -24271,10 +24214,10 @@ is missing, as in the above example, this parameter is set to be the When importing a variable defined in C, you should always use the @code{C} calling convention unless the object containing the variable is part of a DLL (in which case you should use the @code{Stdcall} calling -convention, @ref{1f0,,Stdcall Calling Convention}). +convention, @ref{1ea,,Stdcall Calling Convention}). @node Stdcall Calling Convention,Win32 Calling Convention,C Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1f0}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1f1} +@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1ea}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1eb} @subsubsection @code{Stdcall} Calling Convention @@ -24371,7 +24314,7 @@ Note that to ease building cross-platform bindings this convention will be handled as a @code{C} calling convention on non-Windows platforms. @node Win32 Calling Convention,DLL Calling Convention,Stdcall Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1f2}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1f3} +@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1ec}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1ed} @subsubsection @code{Win32} Calling Convention @@ -24379,7 +24322,7 @@ This convention, which is GNAT-specific is fully equivalent to the @code{Stdcall} calling convention described above. @node DLL Calling Convention,,Win32 Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information id18}@anchor{1f4}@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1f5} +@anchor{gnat_ugn/platform_specific_information id18}@anchor{1ee}@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1ef} @subsubsection @code{DLL} Calling Convention @@ -24387,7 +24330,7 @@ This convention, which is GNAT-specific is fully equivalent to the @code{Stdcall} calling convention described above. @node Introduction to Dynamic Link Libraries DLLs,Using DLLs with GNAT,Windows Calling Conventions,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id19}@anchor{1f6}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1f7} +@anchor{gnat_ugn/platform_specific_information id19}@anchor{1f0}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1f1} @subsubsection Introduction to Dynamic Link Libraries (DLLs) @@ -24471,10 +24414,10 @@ As a side note, an interesting difference between Microsoft DLLs and Unix shared libraries, is the fact that on most Unix systems all public routines are exported by default in a Unix shared library, while under Windows it is possible (but not required) to list exported routines in -a definition file (see @ref{1f8,,The Definition File}). +a definition file (see @ref{1f2,,The Definition File}). @node Using DLLs with GNAT,Building DLLs with GNAT Project files,Introduction to Dynamic Link Libraries DLLs,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id20}@anchor{1f9}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1ea} +@anchor{gnat_ugn/platform_specific_information id20}@anchor{1f3}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1e4} @subsubsection Using DLLs with GNAT @@ -24565,7 +24508,7 @@ example a fictitious DLL called @code{API.dll}. @end menu @node Creating an Ada Spec for the DLL Services,Creating an Import Library,,Using DLLs with GNAT -@anchor{gnat_ugn/platform_specific_information id21}@anchor{1fa}@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1fb} +@anchor{gnat_ugn/platform_specific_information id21}@anchor{1f4}@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1f5} @subsubsection Creating an Ada Spec for the DLL Services @@ -24605,7 +24548,7 @@ end API; @end quotation @node Creating an Import Library,,Creating an Ada Spec for the DLL Services,Using DLLs with GNAT -@anchor{gnat_ugn/platform_specific_information id22}@anchor{1fc}@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1fd} +@anchor{gnat_ugn/platform_specific_information id22}@anchor{1f6}@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1f7} @subsubsection Creating an Import Library @@ -24619,7 +24562,7 @@ as in this case it is possible to link directly against the DLL. Otherwise read on. @geindex Definition file -@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1f8} +@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1f2} @subsubheading The Definition File @@ -24667,17 +24610,17 @@ EXPORTS @end table Note that you must specify the correct suffix (@code{@@@emph{nn}}) -(see @ref{1ec,,Windows Calling Conventions}) for a Stdcall +(see @ref{1e6,,Windows Calling Conventions}) for a Stdcall calling convention function in the exported symbols list. There can actually be other sections in a definition file, but these sections are not relevant to the discussion at hand. -@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1fe} +@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1f8} @subsubheading Creating a Definition File Automatically You can automatically create the definition file @code{API.def} -(see @ref{1f8,,The Definition File}) from a DLL. +(see @ref{1f2,,The Definition File}) from a DLL. For that use the @code{dlltool} program as follows: @quotation @@ -24687,7 +24630,7 @@ $ dlltool API.dll -z API.def --export-all-symbols @end example Note that if some routines in the DLL have the @code{Stdcall} convention -(@ref{1ec,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}} +(@ref{1e6,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}} suffix then you'll have to edit @code{api.def} to add it, and specify @code{-k} to @code{gnatdll} when creating the import library. @@ -24711,13 +24654,13 @@ tells you what symbol is expected. You just have to go back to the definition file and add the right suffix. @end itemize @end quotation -@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1ff} +@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1f9} @subsubheading GNAT-Style Import Library To create a static import library from @code{API.dll} with the GNAT tools you should create the .def file, then use @code{gnatdll} tool -(see @ref{200,,Using gnatdll}) as follows: +(see @ref{1fa,,Using gnatdll}) as follows: @quotation @@ -24733,15 +24676,15 @@ definition file name is @code{xyz.def}, the import library name will be @code{libxyz.a}. Note that in the previous example option @code{-e} could have been removed because the name of the definition file (before the @code{.def} suffix) is the same as the name of the -DLL (@ref{200,,Using gnatdll} for more information about @code{gnatdll}). +DLL (@ref{1fa,,Using gnatdll} for more information about @code{gnatdll}). @end quotation -@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{201} +@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{1fb} @subsubheading Microsoft-Style Import Library A Microsoft import library is needed only if you plan to make an Ada DLL available to applications developed with Microsoft -tools (@ref{1e9,,Mixed-Language Programming on Windows}). +tools (@ref{1e3,,Mixed-Language Programming on Windows}). To create a Microsoft-style import library for @code{API.dll} you should create the .def file, then build the actual import library using @@ -24765,7 +24708,7 @@ See the Microsoft documentation for further details about the usage of @end quotation @node Building DLLs with GNAT Project files,Building DLLs with GNAT,Using DLLs with GNAT,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id23}@anchor{202}@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1eb} +@anchor{gnat_ugn/platform_specific_information id23}@anchor{1fc}@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1e5} @subsubsection Building DLLs with GNAT Project files @@ -24781,7 +24724,7 @@ when inside the @code{DllMain} routine which is used for auto-initialization of shared libraries, so it is not possible to have library level tasks in SALs. @node Building DLLs with GNAT,Building DLLs with gnatdll,Building DLLs with GNAT Project files,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{203}@anchor{gnat_ugn/platform_specific_information id24}@anchor{204} +@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information id24}@anchor{1fe} @subsubsection Building DLLs with GNAT @@ -24812,7 +24755,7 @@ $ gcc -shared -shared-libgcc -o api.dll obj1.o obj2.o ... It is important to note that in this case all symbols found in the object files are automatically exported. It is possible to restrict the set of symbols to export by passing to @code{gcc} a definition -file (see @ref{1f8,,The Definition File}). +file (see @ref{1f2,,The Definition File}). For example: @example @@ -24850,7 +24793,7 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI @end quotation @node Building DLLs with gnatdll,Ada DLLs and Finalization,Building DLLs with GNAT,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{205}@anchor{gnat_ugn/platform_specific_information id25}@anchor{206} +@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{1ff}@anchor{gnat_ugn/platform_specific_information id25}@anchor{200} @subsubsection Building DLLs with gnatdll @@ -24858,8 +24801,8 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI @geindex building Note that it is preferred to use GNAT Project files -(@ref{1eb,,Building DLLs with GNAT Project files}) or the built-in GNAT -DLL support (@ref{203,,Building DLLs with GNAT}) or to build DLLs. +(@ref{1e5,,Building DLLs with GNAT Project files}) or the built-in GNAT +DLL support (@ref{1fd,,Building DLLs with GNAT}) or to build DLLs. This section explains how to build DLLs containing Ada code using @code{gnatdll}. These DLLs will be referred to as Ada DLLs in the @@ -24875,20 +24818,20 @@ non-Ada applications are as follows: You need to mark each Ada entity exported by the DLL with a @code{C} or @code{Stdcall} calling convention to avoid any Ada name mangling for the entities exported by the DLL -(see @ref{207,,Exporting Ada Entities}). You can +(see @ref{201,,Exporting Ada Entities}). You can skip this step if you plan to use the Ada DLL only from Ada applications. @item Your Ada code must export an initialization routine which calls the routine @code{adainit} generated by @code{gnatbind} to perform the elaboration of -the Ada code in the DLL (@ref{208,,Ada DLLs and Elaboration}). The initialization +the Ada code in the DLL (@ref{202,,Ada DLLs and Elaboration}). The initialization routine exported by the Ada DLL must be invoked by the clients of the DLL to initialize the DLL. @item When useful, the DLL should also export a finalization routine which calls routine @code{adafinal} generated by @code{gnatbind} to perform the -finalization of the Ada code in the DLL (@ref{209,,Ada DLLs and Finalization}). +finalization of the Ada code in the DLL (@ref{203,,Ada DLLs and Finalization}). The finalization routine exported by the Ada DLL must be invoked by the clients of the DLL when the DLL services are no further needed. @@ -24898,11 +24841,11 @@ of the programming languages to which you plan to make the DLL available. @item You must provide a definition file listing the exported entities -(@ref{1f8,,The Definition File}). +(@ref{1f2,,The Definition File}). @item Finally you must use @code{gnatdll} to produce the DLL and the import -library (@ref{200,,Using gnatdll}). +library (@ref{1fa,,Using gnatdll}). @end itemize Note that a relocatable DLL stripped using the @code{strip} @@ -24922,7 +24865,7 @@ chapter of the @emph{GPRbuild User's Guide}. @end menu @node Limitations When Using Ada DLLs from Ada,Exporting Ada Entities,,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{20a} +@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{204} @subsubsection Limitations When Using Ada DLLs from Ada @@ -24943,7 +24886,7 @@ It is completely safe to exchange plain elementary, array or record types, Windows object handles, etc. @node Exporting Ada Entities,Ada DLLs and Elaboration,Limitations When Using Ada DLLs from Ada,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{207}@anchor{gnat_ugn/platform_specific_information id26}@anchor{20b} +@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{201}@anchor{gnat_ugn/platform_specific_information id26}@anchor{205} @subsubsection Exporting Ada Entities @@ -25043,10 +24986,10 @@ end API; Note that if you do not export the Ada entities with a @code{C} or @code{Stdcall} convention you will have to provide the mangled Ada names in the definition file of the Ada DLL -(@ref{20c,,Creating the Definition File}). +(@ref{206,,Creating the Definition File}). @node Ada DLLs and Elaboration,,Exporting Ada Entities,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{208}@anchor{gnat_ugn/platform_specific_information id27}@anchor{20d} +@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{202}@anchor{gnat_ugn/platform_specific_information id27}@anchor{207} @subsubsection Ada DLLs and Elaboration @@ -25064,7 +25007,7 @@ the Ada elaboration routine @code{adainit} generated by the GNAT binder (@ref{b4,,Binding with Non-Ada Main Programs}). See the body of @code{Initialize_Api} for an example. Note that the GNAT binder is automatically invoked during the DLL build process by the @code{gnatdll} -tool (@ref{200,,Using gnatdll}). +tool (@ref{1fa,,Using gnatdll}). When a DLL is loaded, Windows systematically invokes a routine called @code{DllMain}. It would therefore be possible to call @code{adainit} @@ -25077,7 +25020,7 @@ time), which means that the GNAT run-time will deadlock waiting for the newly created task to complete its initialization. @node Ada DLLs and Finalization,Creating a Spec for Ada DLLs,Building DLLs with gnatdll,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id28}@anchor{20e}@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{209} +@anchor{gnat_ugn/platform_specific_information id28}@anchor{208}@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{203} @subsubsection Ada DLLs and Finalization @@ -25092,10 +25035,10 @@ routine @code{adafinal} generated by the GNAT binder See the body of @code{Finalize_Api} for an example. As already pointed out the GNAT binder is automatically invoked during the DLL build process by the @code{gnatdll} tool -(@ref{200,,Using gnatdll}). +(@ref{1fa,,Using gnatdll}). @node Creating a Spec for Ada DLLs,GNAT and Windows Resources,Ada DLLs and Finalization,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id29}@anchor{20f}@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{210} +@anchor{gnat_ugn/platform_specific_information id29}@anchor{209}@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{20a} @subsubsection Creating a Spec for Ada DLLs @@ -25153,7 +25096,7 @@ end API; @end menu @node Creating the Definition File,Using gnatdll,,Creating a Spec for Ada DLLs -@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{20c}@anchor{gnat_ugn/platform_specific_information id30}@anchor{211} +@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{206}@anchor{gnat_ugn/platform_specific_information id30}@anchor{20b} @subsubsection Creating the Definition File @@ -25189,7 +25132,7 @@ EXPORTS @end quotation @node Using gnatdll,,Creating the Definition File,Creating a Spec for Ada DLLs -@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{200}@anchor{gnat_ugn/platform_specific_information id31}@anchor{212} +@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1fa}@anchor{gnat_ugn/platform_specific_information id31}@anchor{20c} @subsubsection Using @code{gnatdll} @@ -25400,7 +25343,7 @@ asks @code{gnatlink} to generate the routines @code{DllMain} and is loaded into memory. @item -@code{gnatdll} uses @code{dlltool} (see @ref{213,,Using dlltool}) to build the +@code{gnatdll} uses @code{dlltool} (see @ref{20d,,Using dlltool}) to build the export table (@code{api.exp}). The export table contains the relocation information in a form which can be used during the final link to ensure that the Windows loader is able to place the DLL anywhere in memory. @@ -25439,7 +25382,7 @@ $ gnatbind -n api $ gnatlink api api.exp -o api.dll -mdll @end example @end itemize -@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{213} +@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{20d} @subsubheading Using @code{dlltool} @@ -25498,7 +25441,7 @@ DLL in the static import library generated by @code{dlltool} with switch @item @code{-k} Kill @code{@@@emph{nn}} from exported names -(@ref{1ec,,Windows Calling Conventions} +(@ref{1e6,,Windows Calling Conventions} for a discussion about @code{Stdcall}-style symbols. @end table @@ -25554,7 +25497,7 @@ Use @code{assembler-name} as the assembler. The default is @code{as}. @end table @node GNAT and Windows Resources,Using GNAT DLLs from Microsoft Visual Studio Applications,Creating a Spec for Ada DLLs,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{214}@anchor{gnat_ugn/platform_specific_information id32}@anchor{215} +@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{20e}@anchor{gnat_ugn/platform_specific_information id32}@anchor{20f} @subsubsection GNAT and Windows Resources @@ -25649,7 +25592,7 @@ the corresponding Microsoft documentation. @end menu @node Building Resources,Compiling Resources,,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{216}@anchor{gnat_ugn/platform_specific_information id33}@anchor{217} +@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{210}@anchor{gnat_ugn/platform_specific_information id33}@anchor{211} @subsubsection Building Resources @@ -25669,7 +25612,7 @@ complete description of the resource script language can be found in the Microsoft documentation. @node Compiling Resources,Using Resources,Building Resources,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{218}@anchor{gnat_ugn/platform_specific_information id34}@anchor{219} +@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{212}@anchor{gnat_ugn/platform_specific_information id34}@anchor{213} @subsubsection Compiling Resources @@ -25711,7 +25654,7 @@ $ windres -i myres.res -o myres.o @end quotation @node Using Resources,,Compiling Resources,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{21a}@anchor{gnat_ugn/platform_specific_information id35}@anchor{21b} +@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{214}@anchor{gnat_ugn/platform_specific_information id35}@anchor{215} @subsubsection Using Resources @@ -25731,7 +25674,7 @@ $ gnatmake myprog -largs myres.o @end quotation @node Using GNAT DLLs from Microsoft Visual Studio Applications,Debugging a DLL,GNAT and Windows Resources,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{21c}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{21d} +@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{216}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{217} @subsubsection Using GNAT DLLs from Microsoft Visual Studio Applications @@ -25765,7 +25708,7 @@ $ gprbuild -p mylib.gpr @item Produce a .def file for the symbols you need to interface with, either by hand or automatically with possibly some manual adjustments -(see @ref{1fe,,Creating Definition File Automatically}): +(see @ref{1f8,,Creating Definition File Automatically}): @end enumerate @quotation @@ -25782,7 +25725,7 @@ $ dlltool libmylib.dll -z libmylib.def --export-all-symbols Make sure that MSVS command-line tools are accessible on the path. @item -Create the Microsoft-style import library (see @ref{201,,MSVS-Style Import Library}): +Create the Microsoft-style import library (see @ref{1fb,,MSVS-Style Import Library}): @end enumerate @quotation @@ -25824,7 +25767,7 @@ or copy the DLL into into the directory containing the .exe. @end enumerate @node Debugging a DLL,Setting Stack Size from gnatlink,Using GNAT DLLs from Microsoft Visual Studio Applications,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id36}@anchor{21e}@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{21f} +@anchor{gnat_ugn/platform_specific_information id36}@anchor{218}@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{219} @subsubsection Debugging a DLL @@ -25862,7 +25805,7 @@ tools suite used to build the DLL. @end menu @node Program and DLL Both Built with GCC/GNAT,Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Debugging a DLL -@anchor{gnat_ugn/platform_specific_information id37}@anchor{220}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{221} +@anchor{gnat_ugn/platform_specific_information id37}@anchor{21a}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{21b} @subsubsection Program and DLL Both Built with GCC/GNAT @@ -25872,7 +25815,7 @@ the process. Let's suppose here that the main procedure is named @code{ada_main} and that in the DLL there is an entry point named @code{ada_dll}. -The DLL (@ref{1f7,,Introduction to Dynamic Link Libraries (DLLs)}) and +The DLL (@ref{1f1,,Introduction to Dynamic Link Libraries (DLLs)}) and program must have been built with the debugging information (see GNAT -g switch). Here are the step-by-step instructions for debugging it: @@ -25912,7 +25855,7 @@ you can use the standard approach to debug the whole program (@ref{24,,Running and Debugging Ada Programs}). @node Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Program and DLL Both Built with GCC/GNAT,Debugging a DLL -@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{222}@anchor{gnat_ugn/platform_specific_information id38}@anchor{223} +@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{21c}@anchor{gnat_ugn/platform_specific_information id38}@anchor{21d} @subsubsection Program Built with Foreign Tools and DLL Built with GCC/GNAT @@ -25929,7 +25872,7 @@ example some C code built with Microsoft Visual C) and that there is a DLL named @code{test.dll} containing an Ada entry point named @code{ada_dll}. -The DLL (see @ref{1f7,,Introduction to Dynamic Link Libraries (DLLs)}) must have +The DLL (see @ref{1f1,,Introduction to Dynamic Link Libraries (DLLs)}) must have been built with debugging information (see the GNAT @code{-g} option). @subsubheading Debugging the DLL Directly @@ -26068,7 +26011,7 @@ approach to debug a program as described in @ref{24,,Running and Debugging Ada Programs}. @node Setting Stack Size from gnatlink,Setting Heap Size from gnatlink,Debugging a DLL,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{136}@anchor{gnat_ugn/platform_specific_information id39}@anchor{224} +@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{136}@anchor{gnat_ugn/platform_specific_information id39}@anchor{21e} @subsubsection Setting Stack Size from @code{gnatlink} @@ -26111,7 +26054,7 @@ because the comma is a separator for this option. @end itemize @node Setting Heap Size from gnatlink,,Setting Stack Size from gnatlink,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{137}@anchor{gnat_ugn/platform_specific_information id40}@anchor{225} +@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{137}@anchor{gnat_ugn/platform_specific_information id40}@anchor{21f} @subsubsection Setting Heap Size from @code{gnatlink} @@ -26144,7 +26087,7 @@ because the comma is a separator for this option. @end itemize @node Windows Specific Add-Ons,,Mixed-Language Programming on Windows,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{226}@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{227} +@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{220}@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{221} @subsection Windows Specific Add-Ons @@ -26157,7 +26100,7 @@ This section describes the Windows specific add-ons. @end menu @node Win32Ada,wPOSIX,,Windows Specific Add-Ons -@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{228}@anchor{gnat_ugn/platform_specific_information id41}@anchor{229} +@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{222}@anchor{gnat_ugn/platform_specific_information id41}@anchor{223} @subsubsection Win32Ada @@ -26188,7 +26131,7 @@ gprbuild p.gpr @end quotation @node wPOSIX,,Win32Ada,Windows Specific Add-Ons -@anchor{gnat_ugn/platform_specific_information id42}@anchor{22a}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{22b} +@anchor{gnat_ugn/platform_specific_information id42}@anchor{224}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{225} @subsubsection wPOSIX @@ -26221,7 +26164,7 @@ gprbuild p.gpr @end quotation @node Mac OS Topics,,Microsoft Windows Topics,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{2d}@anchor{gnat_ugn/platform_specific_information id43}@anchor{22c} +@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{2d}@anchor{gnat_ugn/platform_specific_information id43}@anchor{226} @section Mac OS Topics @@ -26236,7 +26179,7 @@ platform. @end menu @node Codesigning the Debugger,,,Mac OS Topics -@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{22d} +@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{227} @subsection Codesigning the Debugger @@ -26317,7 +26260,7 @@ the location where you installed GNAT. Also, be sure that users are in the Unix group @code{_developer}. @node Example of Binder Output File,Elaboration Order Handling in GNAT,Platform-Specific Information,Top -@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output doc}@anchor{22e}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{22f} +@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output doc}@anchor{228}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{229} @chapter Example of Binder Output File @@ -27069,7 +27012,7 @@ elaboration code in your own application). @c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit @node Elaboration Order Handling in GNAT,Inline Assembler,Example of Binder Output File,Top -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{230}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{231} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{22a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{22b} @chapter Elaboration Order Handling in GNAT @@ -27103,7 +27046,7 @@ GNAT, either automatically or with explicit programming features. @end menu @node Elaboration Code,Elaboration Order,,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{232}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{233} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{22c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{22d} @section Elaboration Code @@ -27245,7 +27188,7 @@ elaborated. @end itemize @node Elaboration Order,Checking the Elaboration Order,Elaboration Code,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{234}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{235} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{22e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{22f} @section Elaboration Order @@ -27395,7 +27338,7 @@ avoids ABE problems should be chosen, however a compiler may not always find such an order due to complications with respect to control and data flow. @node Checking the Elaboration Order,Controlling the Elaboration Order in Ada,Elaboration Order,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{236}@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{237} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{230}@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{231} @section Checking the Elaboration Order @@ -27457,7 +27400,7 @@ order. @end itemize @node Controlling the Elaboration Order in Ada,Controlling the Elaboration Order in GNAT,Checking the Elaboration Order,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{238}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{239} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{232}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{233} @section Controlling the Elaboration Order in Ada @@ -27785,7 +27728,7 @@ is that the program continues to stay in the last state (one or more correct orders exist) even if maintenance changes the bodies of targets. @node Controlling the Elaboration Order in GNAT,Common Elaboration-model Traits,Controlling the Elaboration Order in Ada,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{23a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{23b} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{234}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{235} @section Controlling the Elaboration Order in GNAT @@ -27861,7 +27804,7 @@ The dynamic, legacy, and static models can be relaxed using compiler switch may not diagnose certain elaboration issues or install run-time checks. @node Common Elaboration-model Traits,Dynamic Elaboration Model in GNAT,Controlling the Elaboration Order in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat common-elaboration-model-traits}@anchor{23c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{23d} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat common-elaboration-model-traits}@anchor{236}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{237} @section Common Elaboration-model Traits @@ -27930,7 +27873,7 @@ data and control flow. The warnings can be suppressed selectively with @code{pra Warnigns (Off)} or globally with compiler switch @code{-gnatwL}. @node Dynamic Elaboration Model in GNAT,Static Elaboration Model in GNAT,Common Elaboration-model Traits,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat dynamic-elaboration-model-in-gnat}@anchor{23e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{23f} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat dynamic-elaboration-model-in-gnat}@anchor{238}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{239} @section Dynamic Elaboration Model in GNAT @@ -27987,7 +27930,7 @@ is in effect. @end example @node Static Elaboration Model in GNAT,SPARK Elaboration Model in GNAT,Dynamic Elaboration Model in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat static-elaboration-model-in-gnat}@anchor{240}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{241} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat static-elaboration-model-in-gnat}@anchor{23a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{23b} @section Static Elaboration Model in GNAT @@ -28130,7 +28073,7 @@ elaborated prior to the body of @code{Static_Model}. @end itemize @node SPARK Elaboration Model in GNAT,Legacy Elaboration Model in GNAT,Static Elaboration Model in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{242}@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-elaboration-model-in-gnat}@anchor{243} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{23c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-elaboration-model-in-gnat}@anchor{23d} @section SPARK Elaboration Model in GNAT @@ -28153,7 +28096,7 @@ external, and compiler switch @code{-gnatd.v} is in effect. @end example @node Legacy Elaboration Model in GNAT,Mixing Elaboration Models,SPARK Elaboration Model in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat legacy-elaboration-model-in-gnat}@anchor{244} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat legacy-elaboration-model-in-gnat}@anchor{23e} @section Legacy Elaboration Model in GNAT @@ -28164,7 +28107,7 @@ in terms of diagnostics and run-time checks. The legacy elaboration model is enabled with compiler switch @code{-gnatH}. @node Mixing Elaboration Models,Elaboration Circularities,Legacy Elaboration Model in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{245}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{246} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{23f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{240} @section Mixing Elaboration Models @@ -28208,7 +28151,7 @@ warning: "y.ads" which has static elaboration checks The warnings can be suppressed by binder switch @code{-ws}. @node Elaboration Circularities,Resolving Elaboration Circularities,Mixing Elaboration Models,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{247}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{248} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{241}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{242} @section Elaboration Circularities @@ -28267,7 +28210,7 @@ they @emph{with}, must be elaborated prior to @code{Client}. However, @code{Serv @code{Client}, and this leads to a circularity. @node Resolving Elaboration Circularities,Resolving Task Issues,Elaboration Circularities,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{249}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{24a} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{243}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{244} @section Resolving Elaboration Circularities @@ -28435,7 +28378,7 @@ run-time checks. @end itemize @node Resolving Task Issues,Elaboration-related Compiler Switches,Resolving Elaboration Circularities,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{24b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-task-issues}@anchor{24c} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{245}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-task-issues}@anchor{246} @section Resolving Task Issues @@ -28731,7 +28674,7 @@ static model will verify that no entry calls take place at elaboration time. @end itemize @node Elaboration-related Compiler Switches,Summary of Procedures for Elaboration Control,Resolving Task Issues,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{24d}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id15}@anchor{24e} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{247}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id15}@anchor{248} @section Elaboration-related Compiler Switches @@ -28908,7 +28851,7 @@ checks. The example above will still fail at run time with an ABE. @end table @node Summary of Procedures for Elaboration Control,Inspecting the Chosen Elaboration Order,Elaboration-related Compiler Switches,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{24f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id16}@anchor{250} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{249}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id16}@anchor{24a} @section Summary of Procedures for Elaboration Control @@ -28942,7 +28885,7 @@ indicate why a server unit must be elaborated prior to a client unit. @item If the warnings produced by the static model indicate that a task is -involved, consider the options in section @ref{24b,,Resolving Task Issues}. +involved, consider the options in section @ref{245,,Resolving Task Issues}. @item If none of the steps outlined above resolve the circularity, use a more @@ -28973,7 +28916,7 @@ Use the relaxed legacy dynamic elaboration model, with compiler switches @end itemize @node Inspecting the Chosen Elaboration Order,,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{251}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id17}@anchor{252} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{24b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id17}@anchor{24c} @section Inspecting the Chosen Elaboration Order @@ -29110,7 +29053,7 @@ gdbstr (body) @end example @node Inline Assembler,GNU Free Documentation License,Elaboration Order Handling in GNAT,Top -@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{253}@anchor{gnat_ugn/inline_assembler id1}@anchor{254} +@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{24d}@anchor{gnat_ugn/inline_assembler id1}@anchor{24e} @chapter Inline Assembler @@ -29169,7 +29112,7 @@ and with assembly language programming. @end menu @node Basic Assembler Syntax,A Simple Example of Inline Assembler,,Inline Assembler -@anchor{gnat_ugn/inline_assembler id2}@anchor{255}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{256} +@anchor{gnat_ugn/inline_assembler id2}@anchor{24f}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{250} @section Basic Assembler Syntax @@ -29285,7 +29228,7 @@ Intel: Destination first; for example @code{mov eax, 4}@w{ } @node A Simple Example of Inline Assembler,Output Variables in Inline Assembler,Basic Assembler Syntax,Inline Assembler -@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{257}@anchor{gnat_ugn/inline_assembler id3}@anchor{258} +@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{251}@anchor{gnat_ugn/inline_assembler id3}@anchor{252} @section A Simple Example of Inline Assembler @@ -29434,7 +29377,7 @@ If there are no errors, @code{as} will generate an object file @code{nothing.out}. @node Output Variables in Inline Assembler,Input Variables in Inline Assembler,A Simple Example of Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id4}@anchor{259}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{25a} +@anchor{gnat_ugn/inline_assembler id4}@anchor{253}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{254} @section Output Variables in Inline Assembler @@ -29801,7 +29744,7 @@ end Get_Flags_3; @end quotation @node Input Variables in Inline Assembler,Inlining Inline Assembler Code,Output Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id5}@anchor{25b}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{25c} +@anchor{gnat_ugn/inline_assembler id5}@anchor{255}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{256} @section Input Variables in Inline Assembler @@ -29890,7 +29833,7 @@ _increment__incr.1: @end quotation @node Inlining Inline Assembler Code,Other Asm Functionality,Input Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id6}@anchor{25d}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{25e} +@anchor{gnat_ugn/inline_assembler id6}@anchor{257}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{258} @section Inlining Inline Assembler Code @@ -29961,7 +29904,7 @@ movl %esi,%eax thus saving the overhead of stack frame setup and an out-of-line call. @node Other Asm Functionality,,Inlining Inline Assembler Code,Inline Assembler -@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{25f}@anchor{gnat_ugn/inline_assembler id7}@anchor{260} +@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{259}@anchor{gnat_ugn/inline_assembler id7}@anchor{25a} @section Other @code{Asm} Functionality @@ -29976,7 +29919,7 @@ and @code{Volatile}, which inhibits unwanted optimizations. @end menu @node The Clobber Parameter,The Volatile Parameter,,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{261}@anchor{gnat_ugn/inline_assembler id8}@anchor{262} +@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{25b}@anchor{gnat_ugn/inline_assembler id8}@anchor{25c} @subsection The @code{Clobber} Parameter @@ -30040,7 +29983,7 @@ Use 'register' name @code{memory} if you changed a memory location @end itemize @node The Volatile Parameter,,The Clobber Parameter,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{263}@anchor{gnat_ugn/inline_assembler id9}@anchor{264} +@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{25d}@anchor{gnat_ugn/inline_assembler id9}@anchor{25e} @subsection The @code{Volatile} Parameter @@ -30076,7 +30019,7 @@ to @code{True} only if the compiler's optimizations have created problems. @node GNU Free Documentation License,Index,Inline Assembler,Top -@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{265}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{266} +@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{25f}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{260} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnatchop.adb b/gcc/ada/gnatchop.adb index 7fc942f..96a5236 100644 --- a/gcc/ada/gnatchop.adb +++ b/gcc/ada/gnatchop.adb @@ -599,7 +599,7 @@ procedure Gnatchop is Chop_Name : constant String_Access := File.Table (Num).Name; Save_Stdout : constant File_Descriptor := dup (Standout); Offset_Name : Temp_File_Name; - Offset_FD : File_Descriptor; + Offset_FD : File_Descriptor := Invalid_FD; Buffer : String_Access; Success : Boolean; Failure : exception; @@ -685,10 +685,12 @@ procedure Gnatchop is exception when Failure | Types.Terminate_Program => - Close (Offset_FD); + if Offset_FD /= Invalid_FD then + Close (Offset_FD); + end if; + Delete_File (Offset_Name'Address, Success); return False; - end Parse_File; ----------------------- diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb index 1f4cd4b..dd2e0f6 100644 --- a/gcc/ada/gnatfind.adb +++ b/gcc/ada/gnatfind.adb @@ -75,6 +75,7 @@ procedure Gnatfind is -- Display the usage procedure Write_Usage; + pragma No_Return (Write_Usage); -- Print a small help page for program usage and exit program -------------------- diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index f712a7a..16981b8 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -1102,8 +1102,10 @@ procedure Gnatlink is -- We will be looking for the static version of the library -- as it is in the same directory as the shared version. - if Next_Line (Nlast - Library_Version'Length + 1 .. Nlast) = - Library_Version + if Nlast >= Library_Version'Length + and then Next_Line + (Nlast - Library_Version'Length + 1 .. Nlast) + = Library_Version then -- Set Last to point to last character before the -- library version. diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index f8d36d7..a05b044 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -187,6 +187,7 @@ procedure Gnatls is -- Print usage message procedure Output_License_Information; + pragma No_Return (Output_License_Information); -- Output license statement, and if not found, output reference to COPYING function Image (Restriction : Restriction_Id) return String; @@ -694,40 +695,38 @@ procedure Gnatls is procedure Output_Token (T : Token_Type) is begin - if T in T_No_ALI .. T_Flags then - for J in 1 .. N_Indents loop - Write_Str (" "); - end loop; + case T is + when T_No_ALI .. T_Flags => + for J in 1 .. N_Indents loop + Write_Str (" "); + end loop; - Write_Str (Image (T).all); + Write_Str (Image (T).all); - for J in Image (T)'Length .. 12 loop - Write_Char (' '); - end loop; + for J in Image (T)'Length .. 12 loop + Write_Char (' '); + end loop; - Write_Str ("=>"); + Write_Str ("=>"); - if T in T_No_ALI .. T_With then - Write_Eol; - elsif T in T_Source .. T_Name then - Write_Char (' '); - end if; - - elsif T in T_Preelaborated .. T_Body then - if T in T_Preelaborated .. T_Is_Generic then - if N_Flags = 0 then - Output_Token (T_Flags); + if T in T_No_ALI .. T_With then + Write_Eol; + elsif T in T_Source .. T_Name then + Write_Char (' '); end if; - N_Flags := N_Flags + 1; - end if; + when T_Preelaborated .. T_Body => + if T in T_Preelaborated .. T_Is_Generic then + if N_Flags = 0 then + Output_Token (T_Flags); + end if; - Write_Char (' '); - Write_Str (Image (T).all); + N_Flags := N_Flags + 1; + end if; - else - Write_Str (Image (T).all); - end if; + Write_Char (' '); + Write_Str (Image (T).all); + end case; end Output_Token; ----------------- diff --git a/gcc/ada/gnatmake.ads b/gcc/ada/gnatmake.ads index 13bde86..d98e717 100644 --- a/gcc/ada/gnatmake.ads +++ b/gcc/ada/gnatmake.ads @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ procedure Gnatmake; +pragma No_Return (Gnatmake); -- The driver for the gnatmake tool. This utility can be used to automatically -- (re)compile a set of ada sources by giving the name of the root compilation -- unit or the source file containing it. For more information on gnatmake diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index 5a7b56c..a55243d 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -38,7 +38,7 @@ package Gnatvsn is -- Static string identifying this version, that can be used as an argument -- to e.g. pragma Ident. - Library_Version : constant String := "8"; + Library_Version : constant String := "9"; -- Library version. It needs to be updated whenever the major version -- number is changed. -- diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb index 2991fc5..3714fff 100644 --- a/gcc/ada/gnatxref.adb +++ b/gcc/ada/gnatxref.adb @@ -63,6 +63,7 @@ procedure Gnatxref is -- Display the usage procedure Write_Usage; + pragma No_Return (Write_Usage); -- Print a small help page for program usage -------------------- diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 336b336..8f0b75d 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -197,10 +197,10 @@ package body Inline is function Has_Single_Return (N : Node_Id) return Boolean; -- In general we cannot inline functions that return unconstrained type. - -- However, we can handle such functions if all return statements return a - -- local variable that is the only declaration in the body of the function. - -- In that case the call can be replaced by that local variable as is done - -- for other inlined calls. + -- However, we can handle such functions if all return statements return + -- a local variable that is the first declaration in the body of the + -- function. In that case the call can be replaced by that local + -- variable as is done for other inlined calls. function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean; -- Return True if E is in the main unit or its spec or in a subunit @@ -879,6 +879,10 @@ package body Inline is Body_To_Analyze : Node_Id; Max_Size : constant := 10; + function Has_Extended_Return return Boolean; + -- This function returns True if the subprogram has an extended return + -- statement. + function Has_Pending_Instantiation return Boolean; -- If some enclosing body contains instantiations that appear before -- the corresponding generic body, the enclosing body has a freeze node @@ -896,8 +900,51 @@ package body Inline is function Uses_Secondary_Stack (Bod : Node_Id) return Boolean; -- If the body of the subprogram includes a call that returns an - -- unconstrained type, the secondary stack is involved, and it - -- is not worth inlining. + -- unconstrained type, the secondary stack is involved, and it is + -- not worth inlining. + + ------------------------- + -- Has_Extended_Return -- + ------------------------- + + function Has_Extended_Return return Boolean is + Body_To_Inline : constant Node_Id := N; + + function Check_Return (N : Node_Id) return Traverse_Result; + -- Returns OK on node N if this is not an extended return statement + + ------------------ + -- Check_Return -- + ------------------ + + function Check_Return (N : Node_Id) return Traverse_Result is + begin + case Nkind (N) is + when N_Extended_Return_Statement => + return Abandon; + + -- Skip locally declared subprogram bodies inside the body to + -- inline, as the return statements inside those do not count. + + when N_Subprogram_Body => + if N = Body_To_Inline then + return OK; + else + return Skip; + end if; + + when others => + return OK; + end case; + end Check_Return; + + function Check_All_Returns is new Traverse_Func (Check_Return); + + -- Start of processing for Has_Extended_Return + + begin + return Check_All_Returns (N) /= OK; + end Has_Extended_Return; ------------------------------- -- Has_Pending_Instantiation -- @@ -1038,24 +1085,9 @@ package body Inline is Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id); return; - -- Functions that return unconstrained composite types require - -- secondary stack handling, and cannot currently be inlined, unless - -- all return statements return a local variable that is the first - -- local declaration in the body. - - elsif Ekind (Spec_Id) = E_Function - and then not Is_Scalar_Type (Etype (Spec_Id)) - and then not Is_Access_Type (Etype (Spec_Id)) - and then not Is_Constrained (Etype (Spec_Id)) - then - if not Has_Single_Return (N) then - Cannot_Inline - ("cannot inline & (unconstrained return type)?", N, Spec_Id); - return; - end if; - - -- Ditto for functions that return controlled types, where controlled - -- actions interfere in complex ways with inlining. + -- Functions that return controlled types cannot currently be inlined + -- because they require secondary stack handling; controlled actions + -- may also interfere in complex ways with inlining. elsif Ekind (Spec_Id) = E_Function and then Needs_Finalization (Etype (Spec_Id)) @@ -1178,10 +1210,37 @@ package body Inline is Restore_Env; end if; + -- Functions that return unconstrained composite types require + -- secondary stack handling, and cannot currently be inlined, unless + -- all return statements return a local variable that is the first + -- local declaration in the body. We had to delay this check until + -- the body of the function is analyzed since Has_Single_Return() + -- requires a minimum decoration. + + if Ekind (Spec_Id) = E_Function + and then not Is_Scalar_Type (Etype (Spec_Id)) + and then not Is_Access_Type (Etype (Spec_Id)) + and then not Is_Constrained (Etype (Spec_Id)) + then + if not Has_Single_Return (Body_To_Analyze) + + -- Skip inlining if the function returns an unconstrained type + -- using an extended return statement, since this part of the + -- new inlining model is not yet supported by the current + -- implementation. ??? + + or else (Returns_Unconstrained_Type (Spec_Id) + and then Has_Extended_Return) + then + Cannot_Inline + ("cannot inline & (unconstrained return type)?", N, Spec_Id); + return; + end if; + -- If secondary stack is used, there is no point in inlining. We have -- already issued the warning in this case, so nothing to do. - if Uses_Secondary_Stack (Body_To_Analyze) then + elsif Uses_Secondary_Stack (Body_To_Analyze) then return; end if; @@ -2269,23 +2328,39 @@ package body Inline is Subp : Entity_Id; Orig_Subp : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Is_Predef : constant Boolean := + Decls : constant List_Id := New_List; + Is_Predef : constant Boolean := Is_Predefined_Unit (Get_Source_Unit (Subp)); - Orig_Bod : constant Node_Id := + Loc : constant Source_Ptr := Sloc (N); + Orig_Bod : constant Node_Id := Body_To_Inline (Unit_Declaration_Node (Subp)); + Uses_Back_End : constant Boolean := + Back_End_Inlining and then Optimization_Level > 0; + -- The back-end expansion is used if the target supports back-end + -- inlining and some level of optimixation is required; otherwise + -- the inlining takes place fully as a tree expansion. + Blk : Node_Id; Decl : Node_Id; - Decls : constant List_Id := New_List; - Exit_Lab : Entity_Id := Empty; + Exit_Lab : Entity_Id := Empty; F : Entity_Id; A : Node_Id; - Lab_Decl : Node_Id := Empty; + Lab_Decl : Node_Id := Empty; Lab_Id : Node_Id; New_A : Node_Id; - Num_Ret : Nat := 0; + Num_Ret : Nat := 0; Ret_Type : Entity_Id; + Temp : Entity_Id; + Temp_Typ : Entity_Id; + + Is_Unc : Boolean; + Is_Unc_Decl : Boolean; + -- If the type returned by the function is unconstrained and the call + -- can be inlined, special processing is required. + + Return_Object : Entity_Id := Empty; + -- Entity in declaration in an extended_return_statement Targ : Node_Id := Empty; -- The target of the call. If context is an assignment statement then @@ -2295,17 +2370,6 @@ package body Inline is Targ1 : Node_Id := Empty; -- A separate target used when the return type is unconstrained - Temp : Entity_Id; - Temp_Typ : Entity_Id; - - Return_Object : Entity_Id := Empty; - -- Entity in declaration in an extended_return_statement - - Is_Unc : Boolean; - Is_Unc_Decl : Boolean; - -- If the type returned by the function is unconstrained and the call - -- can be inlined, special processing is required. - procedure Declare_Postconditions_Result; -- When generating C code, declare _Result, which may be used in the -- inlined _Postconditions procedure to verify the return value. @@ -2840,7 +2904,7 @@ package body Inline is begin -- Initializations for old/new semantics - if not Back_End_Inlining then + if not Uses_Back_End then Is_Unc := Is_Array_Type (Etype (Subp)) and then not Is_Constrained (Etype (Subp)); Is_Unc_Decl := False; @@ -2868,18 +2932,6 @@ package body Inline is elsif Nkind (Orig_Bod) in N_Entity then return; - - -- Skip inlining if the function returns an unconstrained type using - -- an extended return statement since this part of the new inlining - -- model which is not yet supported by the current implementation. ??? - - elsif Is_Unc - and then - Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod)))) = - N_Extended_Return_Statement - and then not Back_End_Inlining - then - return; end if; if Nkind (Orig_Bod) = N_Defining_Identifier @@ -2914,7 +2966,7 @@ package body Inline is -- Old semantics - if not Back_End_Inlining then + if not Uses_Back_End then declare Bod : Node_Id; @@ -2958,6 +3010,20 @@ package body Inline is begin First_Decl := First (Declarations (Blk)); + -- If the body is a single extended return statement,the + -- resulting block is a nested block. + + if No (First_Decl) then + First_Decl := + First (Statements (Handled_Statement_Sequence (Blk))); + + if Nkind (First_Decl) = N_Block_Statement then + First_Decl := First (Declarations (First_Decl)); + end if; + end if; + + -- No front-end inlining possible + if Nkind (First_Decl) /= N_Object_Declaration then return; end if; @@ -3229,8 +3295,8 @@ package body Inline is and then Ekind (F) /= E_Out_Parameter and then not Same_Type (Etype (F), Etype (A)) then - pragma Assert (not (Is_By_Reference_Type (Etype (A)))); - pragma Assert (not (Is_Limited_Type (Etype (A)))); + pragma Assert (not Is_By_Reference_Type (Etype (A))); + pragma Assert (not Is_Limited_Type (Etype (A))); Append_To (Decls, Make_Object_Declaration (Loc, @@ -3288,7 +3354,7 @@ package body Inline is -- of the result of a call to an inlined function that returns -- an unconstrained type - elsif Back_End_Inlining + elsif Uses_Back_End and then Nkind (Parent (N)) = N_Object_Declaration and then Is_Unc then @@ -3841,25 +3907,31 @@ package body Inline is if Present (Expression (N)) and then Is_Entity_Name (Expression (N)) then + pragma Assert (Present (Entity (Expression (N)))); + if No (Return_Statement) then Return_Statement := N; return OK; - elsif Chars (Expression (N)) = - Chars (Expression (Return_Statement)) - then - return OK; - else - return Abandon; + pragma Assert + (Present (Entity (Expression (Return_Statement)))); + + if Entity (Expression (N)) = + Entity (Expression (Return_Statement)) + then + return OK; + else + return Abandon; + end if; end if; - -- A return statement within an extended return is a noop - -- after inlining. + -- A return statement within an extended return is a noop after + -- inlining. elsif No (Expression (N)) - and then - Nkind (Parent (Parent (N))) = N_Extended_Return_Statement + and then Nkind (Parent (Parent (N))) = + N_Extended_Return_Statement then return OK; @@ -3898,10 +3970,11 @@ package body Inline is return True; else - return Present (Declarations (N)) - and then Present (First (Declarations (N))) - and then Chars (Expression (Return_Statement)) = - Chars (Defining_Identifier (First (Declarations (N)))); + return + Present (Declarations (N)) + and then Present (First (Declarations (N))) + and then Entity (Expression (Return_Statement)) = + Defining_Identifier (First (Declarations (N))); end if; end Has_Single_Return; diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index 0bda097..81f1e29 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -63,21 +63,24 @@ package Inline is -- See full description in body of Sem_Ch12 for more details type Pending_Body_Info is record - Inst_Node : Node_Id; - -- Node for instantiation that requires the body - Act_Decl : Node_Id; -- Declaration for package or subprogram spec for instantiation - Expander_Status : Boolean; - -- If the body is instantiated only for semantic checking, expansion - -- must be inhibited. + Config_Switches : Config_Switches_Type; + -- Capture the values of configuration switches Current_Sem_Unit : Unit_Number_Type; -- The semantic unit within which the instantiation is found. Must be -- restored when compiling the body, to insure that internal entities -- use the same counter and are unique over spec and body. + Expander_Status : Boolean; + -- If the body is instantiated only for semantic checking, expansion + -- must be inhibited. + + Inst_Node : Node_Id; + -- Node for instantiation that requires the body + Scope_Suppress : Suppress_Record; Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; -- Save suppress information at the point of instantiation. Used to @@ -93,21 +96,8 @@ package Inline is -- This means we have to capture this information from the current scope -- at the point of instantiation. - Version : Ada_Version_Type; - -- The body must be compiled with the same language version as the - -- spec. The version may be set by a configuration pragma in a separate - -- file or in the current file, and may differ from body to body. - - Version_Pragma : Node_Id; - -- This is linked with the Version value - Warnings : Warning_Record; -- Capture values of warning flags - - SPARK_Mode : SPARK_Mode_Type; - SPARK_Mode_Pragma : Node_Id; - -- SPARK_Mode for an instance is the one applicable at the point of - -- instantiation. SPARK_Mode_Pragma is the related active pragma. end record; package Pending_Instantiations is new Table.Table ( diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 3598311..9a54fa9 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -950,20 +950,35 @@ package body Lib.Writ is Write_Info_Tab (25); if Is_Spec_Name (Uname) then - Body_Fname := - Get_File_Name - (Get_Body_Name (Uname), - Subunit => False, May_Fail => True); - - Body_Index := - Get_Unit_Index - (Get_Body_Name (Uname)); - - if Body_Fname = No_File then - Body_Fname := Get_File_Name (Uname, Subunit => False); - Body_Index := Get_Unit_Index (Uname); - end if; + -- In GNATprove mode we must write the spec of a unit which + -- requires a body if that body is not found. This will + -- allow partial analysis on incomplete sources. + + if GNATprove_Mode then + + Body_Fname := + Get_File_Name (Get_Body_Name (Uname), + Subunit => False, May_Fail => True); + + Body_Index := Get_Unit_Index (Get_Body_Name (Uname)); + + if Body_Fname = No_File then + Body_Fname := Get_File_Name (Uname, Subunit => False); + Body_Index := Get_Unit_Index (Uname); + end if; + + -- In the normal path we don't allow failure in fetching the + -- name of the desired body unit so that it may be properly + -- referenced in the output ali - even if it is missing. + + else + Body_Fname := + Get_File_Name (Get_Body_Name (Uname), + Subunit => False, May_Fail => False); + + Body_Index := Get_Unit_Index (Get_Body_Name (Uname)); + end if; else Body_Fname := Get_File_Name (Uname, Subunit => False); Body_Index := Get_Unit_Index (Uname); diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 5b79c43..df391a8 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -629,13 +629,13 @@ package Lib.Writ is -- by the current unit. One Z line is present for each unit that is -- only implicitly withed by the current unit. The first parameter is -- the unit name in internal format. The second parameter is the file - -- name of the file that must be compiled to compile this unit. It is - -- usually the file for the body, except for packages which have no - -- body. For units that need a body, if the source file for the body - -- cannot be found, the file name of the spec is used instead. The - -- third parameter is the file name of the library information file - -- that contains the results of compiling this unit. The optional - -- modifiers are used as follows: + -- name of the body unit on which the current compliation depends - + -- except when in GNATprove mode. In GNATprove mode, when packages + -- which require a body have no associated source file, the file name + -- of the spec is used instead to allow partial analysis of incomplete + -- sources. The third parameter is the file name of the library + -- information file that contains the results of compiling this unit. + -- The optional modifiers are used as follows: -- E pragma Elaborate applies to this unit diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index 834ddc0..0ce834a 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -287,6 +287,7 @@ package body SPARK_Specific is Set_Ekind (Heap, E_Variable); Set_Is_Internal (Heap, True); + Set_Scope (Heap, Standard_Standard); Set_Has_Fully_Qualified_Name (Heap); end Create_Heap; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index eaa7aa6..b3ff466 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -1034,7 +1034,7 @@ package body Lib.Xref is -- parameters may end up being marked as not coming from source -- although they are. Take these into account specially. - elsif GNATprove_Mode and then Ekind (E) in Formal_Kind then + elsif GNATprove_Mode and then Is_Formal (E) then Ent := E; -- Entity does not come from source, but is a derived subprogram and diff --git a/gcc/ada/libgnarl/s-linux__riscv.ads b/gcc/ada/libgnarl/s-linux__riscv.ads new file mode 100644 index 0000000..74420f3 --- /dev/null +++ b/gcc/ada/libgnarl/s-linux__riscv.ads @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . L I N U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2018, 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/>. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RISC-V 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; + +package System.Linux is + pragma Preelaborate; + + ---------- + -- Time -- + ---------- + + subtype int is Interfaces.C.int; + subtype long is Interfaces.C.long; + subtype suseconds_t is Interfaces.C.long; + subtype time_t is Interfaces.C.long; + 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 + SIGBUS : constant := 7; -- bus error + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGUSR1 : constant := 10; -- user defined signal 1 + SIGSEGV : constant := 11; -- segmentation violation + SIGUSR2 : constant := 12; -- user defined signal 2 + 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 + SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) + SIGCLD : constant := 17; -- alias for SIGCHLD + SIGCHLD : constant := 17; -- child status change + SIGCONT : constant := 18; -- stopped process has been continued + SIGSTOP : constant := 19; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 20; -- user stop requested from tty + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGURG : constant := 23; -- urgent condition on IO channel + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 28; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGPOLL : constant := 29; -- pollable event occurred + SIGIO : constant := 29; -- I/O now possible (4.2 BSD) + SIGPWR : constant := 30; -- power-fail restart + SIGSYS : constant := 31; -- bad system call + + SIGLTHRRES : constant := 0; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 0; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 0; -- GNU/LinuxThreads debugger signal + + -- These don't exist for Linux/RISC-V. The constants are present + -- so that we can continue to use a-intnam-linux.ads. + SIGLOST : constant := 0; -- File lock lost + SIGUNUSED : constant := 0; -- unused signal (GNU/Linux) + SIGEMT : constant := 0; -- EMT + + -- struct_sigaction offsets + + sa_handler_pos : constant := 0; + sa_mask_pos : constant := long'Size / 8; + sa_flags_pos : constant := long'Size / 8 + 128; + + SA_SIGINFO : constant := 16#04#; + SA_ONSTACK : constant := 16#08000000#; + +end System.Linux; diff --git a/gcc/ada/libgnarl/s-osinte__solaris.ads b/gcc/ada/libgnarl/s-osinte__solaris.ads index 57d1d5c..8d53d63 100644 --- a/gcc/ada/libgnarl/s-osinte__solaris.ads +++ b/gcc/ada/libgnarl/s-osinte__solaris.ads @@ -536,17 +536,18 @@ private end record; pragma Convention (C, record_type_3); + type upad64_t is new Interfaces.Unsigned_64; + type mutex_t is record flags : record_type_3; - lock : String (1 .. 8); - data : String (1 .. 8); + lock : upad64_t; + data : upad64_t; end record; pragma Convention (C, mutex_t); type cond_t is record - flag : array_type_9; - Xtype : unsigned_long; - data : String (1 .. 8); + flags : record_type_3; + data : upad64_t; end record; pragma Convention (C, cond_t); diff --git a/gcc/ada/libgnat/a-ciorma.adb b/gcc/ada/libgnat/a-ciorma.adb index a981f72..d824760 100644 --- a/gcc/ada/libgnat/a-ciorma.adb +++ b/gcc/ada/libgnat/a-ciorma.adb @@ -541,6 +541,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is "Position cursor of function Element is bad"; end if; + if Checks + and then (Left (Position.Node) = Position.Node + or else + Right (Position.Node) = Position.Node) + then + raise Program_Error with "dangling cursor"; + end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), "Position cursor of function Element is bad"); diff --git a/gcc/ada/libgnat/a-ciormu.adb b/gcc/ada/libgnat/a-ciormu.adb index 2420788..0483f0a 100644 --- a/gcc/ada/libgnat/a-ciormu.adb +++ b/gcc/ada/libgnat/a-ciormu.adb @@ -545,6 +545,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is raise Program_Error with "Position cursor is bad"; end if; + if Checks + and then (Left (Position.Node) = Position.Node + or else + Right (Position.Node) = Position.Node) + then + raise Program_Error with "dangling cursor"; + end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), "bad cursor in Element"); diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb index e656513..7b541e3 100644 --- a/gcc/ada/libgnat/a-ciorse.adb +++ b/gcc/ada/libgnat/a-ciorse.adb @@ -534,6 +534,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Program_Error with "Position cursor is bad"; end if; + if Checks + and then (Left (Position.Node) = Position.Node + or else + Right (Position.Node) = Position.Node) + then + raise Program_Error with "dangling cursor"; + end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), "bad cursor in Element"); diff --git a/gcc/ada/libgnat/a-coorma.adb b/gcc/ada/libgnat/a-coorma.adb index 05eea5b..7ec5077 100644 --- a/gcc/ada/libgnat/a-coorma.adb +++ b/gcc/ada/libgnat/a-coorma.adb @@ -481,6 +481,14 @@ package body Ada.Containers.Ordered_Maps is "Position cursor of function Element equals No_Element"; end if; + if Checks + and then (Left (Position.Node) = Position.Node + or else + Right (Position.Node) = Position.Node) + then + raise Program_Error with "dangling cursor"; + end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), "Position cursor of function Element is bad"); diff --git a/gcc/ada/libgnat/a-coormu.adb b/gcc/ada/libgnat/a-coormu.adb index 0fc1063..c5548bf 100644 --- a/gcc/ada/libgnat/a-coormu.adb +++ b/gcc/ada/libgnat/a-coormu.adb @@ -502,6 +502,14 @@ package body Ada.Containers.Ordered_Multisets is raise Constraint_Error with "Position cursor equals No_Element"; end if; + if Checks + and then (Left (Position.Node) = Position.Node + or else + Right (Position.Node) = Position.Node) + then + raise Program_Error with "dangling cursor"; + end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), "bad cursor in Element"); diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb index 606938e..2033eff 100644 --- a/gcc/ada/libgnat/a-coorse.adb +++ b/gcc/ada/libgnat/a-coorse.adb @@ -480,6 +480,14 @@ package body Ada.Containers.Ordered_Sets is raise Constraint_Error with "Position cursor equals No_Element"; end if; + if Checks + and then (Left (Position.Node) = Position.Node + or else + Right (Position.Node) = Position.Node) + then + raise Program_Error with "dangling cursor"; + end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), "bad cursor in Element"); diff --git a/gcc/ada/libgnat/a-exexpr.adb b/gcc/ada/libgnat/a-exexpr.adb index 2fe003e..20baf0b 100644 --- a/gcc/ada/libgnat/a-exexpr.adb +++ b/gcc/ada/libgnat/a-exexpr.adb @@ -29,7 +29,56 @@ -- -- ------------------------------------------------------------------------------ --- This is the version using the GCC EH mechanism +-- This is the version using the GCC EH mechanism, which could rely on +-- different underlying unwinding engines, for example DWARF or ARM unwind +-- info based. Here is a sketch of the most prominent data structures +-- involved: + +-- (s-excmac.ads) +-- GNAT_GCC_Exception: +-- *-----------------------------------* +-- o-->| (s-excmac.ads) | +-- | | Header : <gcc occurrence type> | +-- | | - Class | +-- | | ... | Constraint_Error: +-- | |-----------------------------------* Program_Error: +-- | | (a-except.ads) | Foreign_Exception: +-- | | Occurrence : Exception_Occurrence | +-- | | | (s-stalib. ads) +-- | | - Id : Exception_Id --------------> Exception_Data +-- o------ - Machine_Occurrence | *------------------------* +-- | - Msg | | Not_Handled_By_Others | +-- | - Traceback | | Lang | +-- | ... | | Foreign_Data --o | +-- *-----------------------------------* | Full_Name | | +-- || | ... | | +-- || foreign rtti blob *----------------|-------* +-- || *---------------* | +-- || | ... ... |<-------------------------o +-- || *---------------* +-- || +-- Setup_Current_Excep() +-- || +-- || Latch into ATCB or +-- || environment Current Exception Buffer: +-- || +-- vv +-- <> : Exception_Occurrence +-- *---------------------------* +-- | ... ... ... ... ... ... * --- Get_Current_Excep() ----> +-- *---------------------------* + +-- On "raise" events, the runtime allocates a new GNAT_GCC_Exception +-- instance and eventually calls into libgcc's Unwind_RaiseException. +-- This part handles the object through the header part only. + +-- During execution, Get_Current_Excep provides a pointer to the +-- Exception_Occurrence being raised or last raised by the current task. + +-- This is actually the address of a statically allocated +-- Exception_Occurrence attached to the current ATCB or to the environment +-- thread into which an occurrence being raised is synchronized at critical +-- points during the raise process, via Setup_Current_Excep. with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; @@ -51,6 +100,22 @@ package body Exception_Propagation is -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- -------------------------------------------------------------- + -- Phase identifiers (Unwind Actions) + + type Unwind_Action is new Integer; + pragma Convention (C, Unwind_Action); + + UA_SEARCH_PHASE : constant Unwind_Action := 1; + UA_CLEANUP_PHASE : constant Unwind_Action := 2; + UA_HANDLER_FRAME : constant Unwind_Action := 4; + UA_FORCE_UNWIND : constant Unwind_Action := 8; + UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension + + pragma Unreferenced + (UA_HANDLER_FRAME, + UA_FORCE_UNWIND, + UA_END_OF_STACK); + procedure GNAT_GCC_Exception_Cleanup (Reason : Unwind_Reason_Code; Excep : not null GNAT_GCC_Exception_Access); @@ -70,10 +135,19 @@ package body Exception_Propagation is -- directly from gigi. function Setup_Current_Excep - (GCC_Exception : not null GCC_Exception_Access) return EOA; + (GCC_Exception : not null GCC_Exception_Access; + Phase : Unwind_Action) return EOA; pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); - -- Write Get_Current_Excep.all from GCC_Exception. Called by the - -- personality routine. + -- Acknowledge GCC_Exception as the current exception object being + -- raised, which could be an Ada or a foreign exception object. Return + -- a pointer to the embedded Ada occurrence for an Ada exception object, + -- to the current exception buffer otherwise. + -- + -- Synchronize the current exception buffer as needed for possible + -- accesses through Get_Current_Except.all afterwards, depending on the + -- Phase bits, received either from the personality routine, from a + -- forced_unwind cleanup handler, or just before the start of propagation + -- for an Ada exception (Phase 0 in this case). procedure Unhandled_Except_Handler (GCC_Exception : not null GCC_Exception_Access); @@ -236,27 +310,41 @@ package body Exception_Propagation is ------------------------- function Setup_Current_Excep - (GCC_Exception : not null GCC_Exception_Access) return EOA + (GCC_Exception : not null GCC_Exception_Access; + Phase : Unwind_Action) return EOA is Excep : constant EOA := Get_Current_Excep.all; begin - -- Setup the exception occurrence if GCC_Exception.Class = GNAT_Exception_Class then - -- From the GCC exception + -- Ada exception : latch the occurrence data in the Current + -- Exception Buffer if needed and return a pointer to the original + -- Ada exception object. This particular object was specifically + -- allocated for this raise and is thus more precise than the fixed + -- Current Exception Buffer address. declare GNAT_Occurrence : constant GNAT_GCC_Exception_Access := To_GNAT_GCC_Exception (GCC_Exception); begin - Excep.all := GNAT_Occurrence.Occurrence; + + -- When reaching here during SEARCH_PHASE, no need to + -- replicate the copy performed at the propagation start. + + if Phase /= UA_SEARCH_PHASE then + Excep.all := GNAT_Occurrence.Occurrence; + end if; return GNAT_Occurrence.Occurrence'Access; end; else - -- A default one + + -- Foreign exception (caught by Ada handler, reaching here from + -- personality routine) : The original exception object doesn't hold + -- an Ada occurrence info. Set the foreign data pointer in the + -- Current Exception Buffer and return the address of the latter. Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); @@ -312,7 +400,12 @@ package body Exception_Propagation is procedure Propagate_GCC_Exception (GCC_Exception : not null GCC_Exception_Access) is - Excep : EOA; + -- Acknowledge the current exception info now, before unwinding + -- starts so it is available even from C++ handlers involved before + -- our personality routine. + + Excep : constant EOA := + Setup_Current_Excep (GCC_Exception, Phase => 0); begin -- Perform a standard raise first. If a regular handler is found, it @@ -326,7 +419,6 @@ package body Exception_Propagation is -- the necessary steps to enable the debugger to gain control while the -- stack is still intact. - Excep := Setup_Current_Excep (GCC_Exception); Notify_Unhandled_Exception (Excep); -- Now, un a forced unwind to trigger cleanups. Control should not @@ -392,7 +484,7 @@ package body Exception_Propagation is is Excep : EOA; begin - Excep := Setup_Current_Excep (GCC_Exception); + Excep := Setup_Current_Excep (GCC_Exception, Phase => UA_CLEANUP_PHASE); Unhandled_Exception_Terminate (Excep); end Unhandled_Except_Handler; diff --git a/gcc/ada/libgnat/a-strunb.adb b/gcc/ada/libgnat/a-strunb.adb index 530550d..da5e2b5 100644 --- a/gcc/ada/libgnat/a-strunb.adb +++ b/gcc/ada/libgnat/a-strunb.adb @@ -763,13 +763,13 @@ package body Ada.Strings.Unbounded is (Source : in out Unbounded_String; Chunk_Size : Natural) is - Growth_Factor : constant := 32; + Growth_Factor : constant := 2; -- The growth factor controls how much extra space is allocated when -- we have to increase the size of an allocated unbounded string. By -- allocating extra space, we avoid the need to reallocate on every -- append, particularly important when a string is built up by repeated -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. + -- 2 means add 1/2 of the length of the string as growth space. Min_Mul_Alloc : constant := Standard'Maximum_Alignment; -- Allocation will be done by a multiple of Min_Mul_Alloc This causes diff --git a/gcc/ada/libgnat/a-strunb__shared.adb b/gcc/ada/libgnat/a-strunb__shared.adb index 21827ed..0e060e3 100644 --- a/gcc/ada/libgnat/a-strunb__shared.adb +++ b/gcc/ada/libgnat/a-strunb__shared.adb @@ -36,13 +36,13 @@ package body Ada.Strings.Unbounded is use Ada.Strings.Maps; - Growth_Factor : constant := 32; + Growth_Factor : constant := 2; -- The growth factor controls how much extra space is allocated when -- we have to increase the size of an allocated unbounded string. By -- allocating extra space, we avoid the need to reallocate on every -- append, particularly important when a string is built up by repeated -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. + -- 2 means add 1/2 of the length of the string as growth space. Min_Mul_Alloc : constant := Standard'Maximum_Alignment; -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes diff --git a/gcc/ada/libgnat/g-arrspl.ads b/gcc/ada/libgnat/g-arrspl.ads index 62d4042..efcc2d4 100644 --- a/gcc/ada/libgnat/g-arrspl.ads +++ b/gcc/ada/libgnat/g-arrspl.ads @@ -56,6 +56,7 @@ generic -- Returns True if Item is found in Set, False otherwise package GNAT.Array_Split is + pragma Preelaborate; Index_Error : exception; -- Raised by all operations below if Index > Field_Count (S) diff --git a/gcc/ada/libgnat/g-comlin.ads b/gcc/ada/libgnat/g-comlin.ads index 1afa57b..da49ce9 100644 --- a/gcc/ada/libgnat/g-comlin.ads +++ b/gcc/ada/libgnat/g-comlin.ads @@ -703,7 +703,8 @@ package GNAT.Command_Line is -- automatically generated list of supported switches. procedure Display_Help (Config : Command_Line_Configuration); - -- Display the help for the tool (ie its usage, and its supported switches) + -- Display the help for the tool (i.e. its usage, and its supported + -- switches). function Get_Switches (Config : Command_Line_Configuration; @@ -843,9 +844,9 @@ package GNAT.Command_Line is -- -- This function can be used to reset Cmd by passing an empty string -- - -- If an invalid switch is found on the command line (ie wasn't defined in - -- the configuration via Define_Switch), and the configuration wasn't set - -- to accept all switches (by defining "*" as a valid switch), then an + -- If an invalid switch is found on the command line (i.e. wasn't defined + -- in the configuration via Define_Switch), and the configuration wasn't + -- set to accept all switches (by defining "*" as a valid switch), then an -- exception Invalid_Switch is raised. The exception message indicates the -- invalid switch. @@ -896,7 +897,7 @@ package GNAT.Command_Line is -- -from bar -- -- Note however that Getopt doesn't know how to handle ":" as a separator. - -- So the recommendation is to declare the switch as "-from!" (ie no + -- So the recommendation is to declare the switch as "-from!" (i.e. no -- space between the switch and its parameter). Then Getopt will return -- ":bar" as the parameter, and you can trim the ":" in your application. -- diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb index e1b311e..721571f 100644 --- a/gcc/ada/libgnat/g-socket.adb +++ b/gcc/ada/libgnat/g-socket.adb @@ -144,8 +144,8 @@ package body GNAT.Sockets is -- Symmetric operation function Image - (Val : Inet_Addr_VN_Type; - Hex : Boolean := False) return String; + (Val : Inet_Addr_Bytes; + Hex : Boolean := False) return String; -- Output an array of inet address components in hex or decimal mode function Is_IP_Address (Name : String) return Boolean; @@ -275,6 +275,15 @@ package body GNAT.Sockets is -- Create_Selector has been called and Close_Selector has not been called, -- or the null selector. + function Create_Address + (Family : Family_Type; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type + with Inline; + -- Creates address from family and Inet_Addr_Bytes array. + + function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes + with Inline; + -- Extract bytes from address + --------- -- "+" -- --------- @@ -1314,7 +1323,7 @@ package body GNAT.Sockets is ----------- function Image - (Val : Inet_Addr_VN_Type; + (Val : Inet_Addr_Bytes; Hex : Boolean := False) return String is -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It @@ -1381,9 +1390,9 @@ package body GNAT.Sockets is function Image (Value : Inet_Addr_Type) return String is begin if Value.Family = Family_Inet then - return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False); + return Image (Inet_Addr_Bytes (Value.Sin_V4), Hex => False); else - return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True); + return Image (Inet_Addr_Bytes (Value.Sin_V6), Hex => True); end if; end Image; @@ -2782,4 +2791,121 @@ package body GNAT.Sockets is -- The elaboration and finalization of this object perform the required -- initialization and cleanup actions for the sockets library. + -------------------- + -- Create_Address -- + -------------------- + + function Create_Address + (Family : Family_Type; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type + is + (case Family is + when Family_Inet => (Family_Inet, Bytes), + when Family_Inet6 => (Family_Inet6, Bytes)); + + --------------- + -- Get_Bytes -- + --------------- + + function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes is + (case Addr.Family is + when Family_Inet => Addr.Sin_V4, + when Family_Inet6 => Addr.Sin_V6); + + ---------- + -- Mask -- + ---------- + + function Mask + (Family : Family_Type; + Length : Natural; + Host : Boolean := False) return Inet_Addr_Type + is + Addr_Len : constant Natural := Inet_Addr_Bytes_Length (Family); + begin + if Length > 8 * Addr_Len then + raise Constraint_Error with + "invalid mask length for address family " & Family'Img; + end if; + + declare + B : Inet_Addr_Bytes (1 .. Addr_Len); + Part : Inet_Addr_Comp_Type; + begin + for J in 1 .. Length / 8 loop + B (J) := (if Host then 0 else 255); + end loop; + + if Length < 8 * Addr_Len then + Part := 2 ** (8 - Length mod 8) - 1; + B (Length / 8 + 1) := (if Host then Part else not Part); + + for J in Length / 8 + 2 .. B'Last loop + B (J) := (if Host then 255 else 0); + end loop; + end if; + + return Create_Address (Family, B); + end; + end Mask; + + ----------- + -- "and" -- + ----------- + + function "and" (Addr, Mask : Inet_Addr_Type) return Inet_Addr_Type is + begin + if Addr.Family /= Mask.Family then + raise Constraint_Error with "incompatible address families"; + end if; + + declare + A : constant Inet_Addr_Bytes := Get_Bytes (Addr); + M : constant Inet_Addr_Bytes := Get_Bytes (Mask); + R : Inet_Addr_Bytes (A'Range); + + begin + for J in A'Range loop + R (J) := A (J) and M (J); + end loop; + return Create_Address (Addr.Family, R); + end; + end "and"; + + ---------- + -- "or" -- + ---------- + + function "or" (Net, Host : Inet_Addr_Type) return Inet_Addr_Type is + begin + if Net.Family /= Host.Family then + raise Constraint_Error with "incompatible address families"; + end if; + + declare + N : constant Inet_Addr_Bytes := Get_Bytes (Net); + H : constant Inet_Addr_Bytes := Get_Bytes (Host); + R : Inet_Addr_Bytes (N'Range); + + begin + for J in N'Range loop + R (J) := N (J) or H (J); + end loop; + return Create_Address (Net.Family, R); + end; + end "or"; + + ----------- + -- "not" -- + ----------- + + function "not" (Mask : Inet_Addr_Type) return Inet_Addr_Type is + M : constant Inet_Addr_Bytes := Get_Bytes (Mask); + R : Inet_Addr_Bytes (M'Range); + begin + for J in R'Range loop + R (J) := not M (J); + end loop; + return Create_Address (Mask.Family, R); + end "not"; + end GNAT.Sockets; diff --git a/gcc/ada/libgnat/g-socket.ads b/gcc/ada/libgnat/g-socket.ads index 731e837..03b3f95 100644 --- a/gcc/ada/libgnat/g-socket.ads +++ b/gcc/ada/libgnat/g-socket.ads @@ -489,7 +489,32 @@ package GNAT.Sockets is No_Port : constant Port_Type; -- Uninitialized port number - type Inet_Addr_Type (Family : Family_Type := Family_Inet) is private; + type Inet_Addr_Comp_Type is mod 2 ** 8; + -- Octet for Internet address + + Inet_Addr_Bytes_Length : constant array (Family_Type) of Positive := + (Family_Inet => 4, Family_Inet6 => 16); + + type Inet_Addr_Bytes is array (Natural range <>) of Inet_Addr_Comp_Type; + + subtype Inet_Addr_V4_Type is + Inet_Addr_Bytes (1 .. Inet_Addr_Bytes_Length (Family_Inet)); + subtype Inet_Addr_V6_Type is + Inet_Addr_Bytes (1 .. Inet_Addr_Bytes_Length (Family_Inet6)); + + subtype Inet_Addr_VN_Type is Inet_Addr_Bytes; + -- For backwards compatibility + + type Inet_Addr_Type (Family : Family_Type := Family_Inet) is record + case Family is + when Family_Inet => + Sin_V4 : Inet_Addr_V4_Type := (others => 0); + + when Family_Inet6 => + Sin_V6 : Inet_Addr_V6_Type := (others => 0); + end case; + end record; + -- An Internet address depends on an address family (IPv4 contains 4 octets -- and IPv6 contains 16 octets). Any_Inet_Addr is a special value treated -- like a wildcard enabling all addresses. No_Inet_Addr provides a special @@ -506,6 +531,23 @@ package GNAT.Sockets is All_Hosts_Group_Inet_Addr : constant Inet_Addr_Type; All_Routers_Group_Inet_Addr : constant Inet_Addr_Type; + -- Functions to handle masks and prefixes + + function Mask + (Family : Family_Type; + Length : Natural; + Host : Boolean := False) return Inet_Addr_Type; + -- Return an address mask of the given family with the given prefix length. + -- If Host is False, this is a network mask (i.e. network bits are 1, + -- and host bits are 0); if Host is True, this is a host mask (i.e. + -- network bits are 0, and host bits are 1). + + function "and" (Addr, Mask : Inet_Addr_Type) return Inet_Addr_Type; + function "or" (Net, Host : Inet_Addr_Type) return Inet_Addr_Type; + function "not" (Mask : Inet_Addr_Type) return Inet_Addr_Type; + -- Bit-wise operations on inet addresses (both operands must have the + -- same address family). + type Sock_Addr_Type (Family : Family_Type := Family_Inet) is record Addr : Inet_Addr_Type (Family); Port : Port_Type; @@ -1213,24 +1255,6 @@ private -- undefined if Last = No_Socket. end record; - subtype Inet_Addr_Comp_Type is Natural range 0 .. 255; - -- Octet for Internet address - - type Inet_Addr_VN_Type is array (Natural range <>) of Inet_Addr_Comp_Type; - - subtype Inet_Addr_V4_Type is Inet_Addr_VN_Type (1 .. 4); - subtype Inet_Addr_V6_Type is Inet_Addr_VN_Type (1 .. 16); - - type Inet_Addr_Type (Family : Family_Type := Family_Inet) is record - case Family is - when Family_Inet => - Sin_V4 : Inet_Addr_V4_Type := (others => 0); - - when Family_Inet6 => - Sin_V6 : Inet_Addr_V6_Type := (others => 0); - end case; - end record; - Any_Port : constant Port_Type := 0; No_Port : constant Port_Type := 0; diff --git a/gcc/ada/libgnat/memtrack.adb b/gcc/ada/libgnat/memtrack.adb index efe0fb1..eba05b4 100644 --- a/gcc/ada/libgnat/memtrack.adb +++ b/gcc/ada/libgnat/memtrack.adb @@ -107,12 +107,6 @@ package body System.Memory is Size : size_t; Nmemb : size_t; Stream : File_Ptr); - - procedure fwrite - (Str : String; - Size : size_t; - Nmemb : size_t; - Stream : File_Ptr); pragma Import (C, fwrite); procedure fputc (C : Integer; Stream : File_Ptr); @@ -306,9 +300,13 @@ package body System.Memory is OS_Exit (255); end if; - fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile); - fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, - Gmemfile); + declare + S : constant String := "GMEM DUMP" & ASCII.LF; + begin + fwrite (S'Address, S'Length, 1, Gmemfile); + fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, + 1, Gmemfile); + end; end if; end Gmem_Initialize; diff --git a/gcc/ada/libgnat/s-elaall.adb b/gcc/ada/libgnat/s-elaall.adb index 78707ce..1c4517a 100644 --- a/gcc/ada/libgnat/s-elaall.adb +++ b/gcc/ada/libgnat/s-elaall.adb @@ -45,7 +45,7 @@ package body System.Elaboration_Allocators is procedure Check_Standard_Allocator is begin if not Elaboration_In_Progress then - raise Program_Error with + raise Storage_Error with "standard allocator after elaboration is complete is not allowed " & "(No_Standard_Allocators_After_Elaboration restriction active)"; end if; diff --git a/gcc/ada/libgnat/s-elaall.ads b/gcc/ada/libgnat/s-elaall.ads index d561ff8..cbe4d69 100644 --- a/gcc/ada/libgnat/s-elaall.ads +++ b/gcc/ada/libgnat/s-elaall.ads @@ -51,7 +51,7 @@ package System.Elaboration_Allocators is procedure Check_Standard_Allocator; -- Called as part of every allocator in a program for which the restriction -- No_Standard_Allocators_After_Elaboration is active. This will raise an - -- exception (Program_Error with an appropriate message) if it is called + -- exception (Storage_Error with an appropriate message) if it is called -- after the call to Mark_End_Of_Elaboration. end System.Elaboration_Allocators; diff --git a/gcc/ada/libgnat/s-excmac__arm.ads b/gcc/ada/libgnat/s-excmac__arm.ads index ae83c62..b188046 100644 --- a/gcc/ada/libgnat/s-excmac__arm.ads +++ b/gcc/ada/libgnat/s-excmac__arm.ads @@ -58,6 +58,7 @@ package System.Exceptions.Machine is URC_INSTALL_CONTEXT, URC_CONTINUE_UNWIND, URC_FAILURE); + pragma Convention (C, Unwind_Reason_Code); pragma Unreferenced (URC_OK, @@ -71,9 +72,7 @@ package System.Exceptions.Machine is URC_CONTINUE_UNWIND, URC_FAILURE); - pragma Convention (C, Unwind_Reason_Code); - subtype Unwind_Action is Unwind_Reason_Code; - -- Phase identifiers + -- ARM Unwinding State type uint32_t is mod 2**32; pragma Convention (C, uint32_t); diff --git a/gcc/ada/libgnat/s-excmac__gcc.ads b/gcc/ada/libgnat/s-excmac__gcc.ads index e299777..a828a02 100644 --- a/gcc/ada/libgnat/s-excmac__gcc.ads +++ b/gcc/ada/libgnat/s-excmac__gcc.ads @@ -75,24 +75,6 @@ package System.Exceptions.Machine is pragma Convention (C, Unwind_Reason_Code); - -- Phase identifiers - - type Unwind_Action is new Integer; - pragma Convention (C, Unwind_Action); - - UA_SEARCH_PHASE : constant Unwind_Action := 1; - UA_CLEANUP_PHASE : constant Unwind_Action := 2; - UA_HANDLER_FRAME : constant Unwind_Action := 4; - UA_FORCE_UNWIND : constant Unwind_Action := 8; - UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension - - pragma Unreferenced - (UA_SEARCH_PHASE, - UA_CLEANUP_PHASE, - UA_HANDLER_FRAME, - UA_FORCE_UNWIND, - UA_END_OF_STACK); - -- Mandatory common header for any exception object handled by the -- GCC unwinding runtime. diff --git a/gcc/ada/libgnat/s-memory__mingw.adb b/gcc/ada/libgnat/s-memory__mingw.adb deleted file mode 100644 index 1fcad5b..0000000 --- a/gcc/ada/libgnat/s-memory__mingw.adb +++ /dev/null @@ -1,221 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2018, 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/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version provides ways to limit the amount of used memory for systems --- that do not have OS support for that. - --- The amount of available memory available for dynamic allocation is limited --- by setting the environment variable GNAT_MEMORY_LIMIT to the number of --- kilobytes that can be used. --- --- Windows is currently using this version. - -with Ada.Exceptions; -with System.Soft_Links; - -package body System.Memory is - - use Ada.Exceptions; - use System.Soft_Links; - - function c_malloc (Size : size_t) return System.Address; - pragma Import (C, c_malloc, "malloc"); - - procedure c_free (Ptr : System.Address); - pragma Import (C, c_free, "free"); - - function c_realloc - (Ptr : System.Address; Size : size_t) return System.Address; - pragma Import (C, c_realloc, "realloc"); - - function msize (Ptr : System.Address) return size_t; - pragma Import (C, msize, "_msize"); - - function getenv (Str : String) return System.Address; - pragma Import (C, getenv); - - function atoi (Str : System.Address) return Integer; - pragma Import (C, atoi); - - Available_Memory : size_t := 0; - -- Amount of memory that is available for heap allocations. - -- A value of 0 means that the amount is not yet initialized. - - Msize_Accuracy : constant := 4096; - -- Defines the amount of memory to add to requested allocation sizes, - -- because malloc may return a bigger block than requested. As msize - -- is used when by Free, it must be used on allocation as well. To - -- prevent underflow of available_memory we need to use a reserve. - - procedure Check_Available_Memory (Size : size_t); - -- This routine must be called while holding the task lock. When the - -- memory limit is not yet initialized, it will be set to the value of - -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that - -- does not exist. If the size is larger than the amount of available - -- memory, the task lock will be freed and a storage_error exception - -- will be raised. - - ----------- - -- Alloc -- - ----------- - - function Alloc (Size : size_t) return System.Address is - Result : System.Address; - Actual_Size : size_t := Size; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - -- Change size from zero to non-zero. We still want a proper pointer - -- for the zero case because pointers to zero length objects have to - -- be distinct, but we can't just go ahead and allocate zero bytes, - -- since some malloc's return zero for a zero argument. - - if Size = 0 then - Actual_Size := 1; - end if; - - Lock_Task.all; - - if Actual_Size + Msize_Accuracy >= Available_Memory then - Check_Available_Memory (Size + Msize_Accuracy); - end if; - - Result := c_malloc (Actual_Size); - - if Result /= System.Null_Address then - Available_Memory := Available_Memory - msize (Result); - end if; - - Unlock_Task.all; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Alloc; - - ---------------------------- - -- Check_Available_Memory -- - ---------------------------- - - procedure Check_Available_Memory (Size : size_t) is - Gnat_Memory_Limit : System.Address; - - begin - if Available_Memory = 0 then - - -- The amount of available memory hasn't been initialized yet - - Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL); - - if Gnat_Memory_Limit /= System.Null_Address then - Available_Memory := - size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy; - else - Available_Memory := size_t'Last; - end if; - end if; - - if Size >= Available_Memory then - - -- There is a memory overflow - - Unlock_Task.all; - Raise_Exception - (Storage_Error'Identity, "heap memory limit exceeded"); - end if; - end Check_Available_Memory; - - ---------- - -- Free -- - ---------- - - procedure Free (Ptr : System.Address) is - begin - Lock_Task.all; - - if Ptr /= System.Null_Address then - Available_Memory := Available_Memory + msize (Ptr); - end if; - - c_free (Ptr); - - Unlock_Task.all; - end Free; - - ------------- - -- Realloc -- - ------------- - - function Realloc - (Ptr : System.Address; - Size : size_t) - return System.Address - is - Result : System.Address; - Actual_Size : constant size_t := Size; - Old_Size : size_t; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - Lock_Task.all; - - Old_Size := msize (Ptr); - - -- Conservative check - no need to try to be precise here - - if Size + Msize_Accuracy >= Available_Memory then - Check_Available_Memory (Size + Msize_Accuracy); - end if; - - Result := c_realloc (Ptr, Actual_Size); - - if Result /= System.Null_Address then - Available_Memory := Available_Memory + Old_Size - msize (Result); - end if; - - Unlock_Task.all; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Realloc; - -end System.Memory; diff --git a/gcc/ada/libgnat/s-objrea.ads b/gcc/ada/libgnat/s-objrea.ads index 1cb08cf..7ab53ed 100644 --- a/gcc/ada/libgnat/s-objrea.ads +++ b/gcc/ada/libgnat/s-objrea.ads @@ -43,14 +43,6 @@ package System.Object_Reader is BUFFER_SIZE : constant := 8 * 1024; - ------------------ - -- Object files -- - ------------------ - - type Object_File (<>) is private; - - type Object_File_Access is access Object_File; - --------------------- -- Object sections -- ---------------------- @@ -88,6 +80,14 @@ package System.Object_Reader is -- PECOFF | PECOFF_PLUS appears so often as a case choice, would -- seem a good idea to have a subtype name covering these two choices ??? + ------------------ + -- Object files -- + ------------------ + + type Object_File (Format : Object_Format) is private; + + type Object_File_Access is access Object_File; + ------------------------------ -- Object architecture type -- ------------------------------ diff --git a/gcc/ada/libgnat/s-os_lib.adb b/gcc/ada/libgnat/s-os_lib.adb index 2569a83..b896daf 100644 --- a/gcc/ada/libgnat/s-os_lib.adb +++ b/gcc/ada/libgnat/s-os_lib.adb @@ -187,93 +187,86 @@ package body System.OS_Lib is (Arg_String : String) return Argument_List_Access is Max_Args : constant Integer := Arg_String'Length; - New_Argv : Argument_List (1 .. Max_Args); + + Backslash_Is_Sep : constant Boolean := Directory_Separator = '\'; + -- Whether '\' is a directory separator (as on Windows), or a way to + -- quote special characters. + + Backqd : Boolean := False; Idx : Integer; New_Argc : Natural := 0; + New_Argv : Argument_List (1 .. Max_Args); + Quoted : Boolean := False; Cleaned : String (1 .. Arg_String'Length); Cleaned_Idx : Natural; -- A cleaned up version of the argument. This function is taking - -- backslash escapes when computing the bounds for arguments. It is - -- then removing the extra backslashes from the argument. - - Backslash_Is_Sep : constant Boolean := Directory_Separator = '\'; - -- Whether '\' is a directory separator (as on Windows), or a way to - -- quote special characters. + -- backslash escapes when computing the bounds for arguments. It + -- is then removing the extra backslashes from the argument. begin Idx := Arg_String'First; loop - exit when Idx > Arg_String'Last; - - declare - Backqd : Boolean := False; - Quoted : Boolean := False; + -- Skip extraneous spaces - begin - Cleaned_Idx := Cleaned'First; + while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop + Idx := Idx + 1; + end loop; - loop - -- An unquoted space is the end of an argument + exit when Idx > Arg_String'Last; - if not (Backqd or Quoted) - and then Arg_String (Idx) = ' ' - then - exit; + Cleaned_Idx := Cleaned'First; + Backqd := False; + Quoted := False; - -- Start of a quoted string + loop + -- An unquoted space is the end of an argument - elsif not (Backqd or Quoted) - and then Arg_String (Idx) = '"' - then - Quoted := True; - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; + if not (Backqd or Quoted) and then Arg_String (Idx) = ' ' then + exit; - -- End of a quoted string and end of an argument + -- Start of a quoted string - elsif (Quoted and not Backqd) - and then Arg_String (Idx) = '"' - then - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; - Idx := Idx + 1; - exit; + elsif not (Backqd or Quoted) and then Arg_String (Idx) = '"' then + Quoted := True; + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; - -- Turn off backquoting after advancing one character + -- End of a quoted string and end of an argument - elsif Backqd then - Backqd := False; - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; + elsif (Quoted and not Backqd) and then Arg_String (Idx) = '"' then + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; + Idx := Idx + 1; + exit; - -- Following character is backquoted + -- Turn off backquoting after advancing one character - elsif not Backslash_Is_Sep and then Arg_String (Idx) = '\' then - Backqd := True; + elsif Backqd then + Backqd := False; + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; - else - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; - end if; + -- Following character is backquoted - Idx := Idx + 1; - exit when Idx > Arg_String'Last; - end loop; + elsif not Backslash_Is_Sep and then Arg_String (Idx) = '\' then + Backqd := True; - -- Found an argument + else + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; + end if; - New_Argc := New_Argc + 1; - New_Argv (New_Argc) := - new String'(Cleaned (Cleaned'First .. Cleaned_Idx - 1)); + Idx := Idx + 1; + exit when Idx > Arg_String'Last; + end loop; - -- Skip extraneous spaces + -- Found an argument - while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop - Idx := Idx + 1; - end loop; - end; + New_Argc := New_Argc + 1; + New_Argv (New_Argc) := + new String'(Cleaned (Cleaned'First .. Cleaned_Idx - 1)); end loop; return new Argument_List'(New_Argv (1 .. New_Argc)); diff --git a/gcc/ada/libgnat/s-valuti.adb b/gcc/ada/libgnat/s-valuti.adb index 8071fca..3070f31 100644 --- a/gcc/ada/libgnat/s-valuti.adb +++ b/gcc/ada/libgnat/s-valuti.adb @@ -39,7 +39,15 @@ package body System.Val_Util is procedure Bad_Value (S : String) is begin - raise Constraint_Error with "bad input for 'Value: """ & S & '"'; + -- Bad_Value might be called with very long strings allocated on the + -- heap. Limit the size of the message so that we avoid creating a + -- Storage_Error during error handling. + if S'Length > 127 then + raise Constraint_Error with "bad input for 'Value: """ + & S (S'First .. S'First + 127) & "..."""; + else + raise Constraint_Error with "bad input for 'Value: """ & S & '"'; + end if; end Bad_Value; ---------------------- diff --git a/gcc/ada/libgnat/s-wchwts.adb b/gcc/ada/libgnat/s-wchwts.adb index c5556ab..4eed382 100644 --- a/gcc/ada/libgnat/s-wchwts.adb +++ b/gcc/ada/libgnat/s-wchwts.adb @@ -86,16 +86,23 @@ package body System.WCh_WtS is (S : Wide_String; EM : WC_Encoding_Method) return String is - R : String (S'First .. S'First + 5 * S'Length); -- worst case length - RP : Natural; + Max_Chars : constant Natural := WC_Longest_Sequences (EM); + + Result : String (S'First .. S'First + Max_Chars * S'Length); + Result_Idx : Natural; begin - RP := R'First - 1; - for SP in S'Range loop - Store_UTF_32_Character (Wide_Character'Pos (S (SP)), R, RP, EM); + Result_Idx := Result'First - 1; + + for S_Idx in S'Range loop + Store_UTF_32_Character + (U => Wide_Character'Pos (S (S_Idx)), + S => Result, + P => Result_Idx, + EM => EM); end loop; - return R (R'First .. RP); + return Result (Result'First .. Result_Idx); end Wide_String_To_String; -------------------------------- @@ -106,17 +113,23 @@ package body System.WCh_WtS is (S : Wide_Wide_String; EM : WC_Encoding_Method) return String is - R : String (S'First .. S'First + 7 * S'Length); -- worst case length - RP : Natural; + Max_Chars : constant Natural := WC_Longest_Sequences (EM); - begin - RP := R'First - 1; + Result : String (S'First .. S'First + Max_Chars * S'Length); + Result_Idx : Natural; - for SP in S'Range loop - Store_UTF_32_Character (Wide_Wide_Character'Pos (S (SP)), R, RP, EM); + begin + Result_Idx := Result'First - 1; + + for S_Idx in S'Range loop + Store_UTF_32_Character + (U => Wide_Wide_Character'Pos (S (S_Idx)), + S => Result, + P => Result_Idx, + EM => EM); end loop; - return R (R'First .. RP); + return Result (Result'First .. Result_Idx); end Wide_Wide_String_To_String; end System.WCh_WtS; diff --git a/gcc/ada/libgnat/system-linux-riscv.ads b/gcc/ada/libgnat/system-linux-riscv.ads new file mode 100644 index 0000000..8e43b40 --- /dev/null +++ b/gcc/ada/libgnat/system-linux-riscv.ads @@ -0,0 +1,147 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/RISC-V Version) -- +-- -- +-- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := Integer'Last; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-rtems.ads b/gcc/ada/libgnat/system-rtems.ads index ce1ce2b..8e7b60e 100644 --- a/gcc/ada/libgnat/system-rtems.ads +++ b/gcc/ada/libgnat/system-rtems.ads @@ -160,7 +160,7 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := True; - ZCX_By_Default : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index cbc8dac..953db42 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -85,6 +85,7 @@ package body Make is procedure Sigint_Intercepted; pragma Convention (C, Sigint_Intercepted); + pragma No_Return (Sigint_Intercepted); -- Called when the program is interrupted by Ctrl-C to delete the -- temporary mapping files and configuration pragmas files. @@ -254,6 +255,7 @@ package body Make is No_Shared_Libgcc_Switch'Access; procedure Make_Failed (S : String); + pragma No_Return (Make_Failed); -- Delete all temp files created by Gnatmake and call Osint.Fail, with the -- parameter S (see osint.ads). @@ -545,6 +547,7 @@ package body Make is -- Display_Executed_Programs is set. The lower bound of Args must be 1. procedure Report_Compilation_Failed; + pragma No_Return (Report_Compilation_Failed); -- Delete all temporary files and fail graciously ----------------- @@ -580,7 +583,7 @@ package body Make is Gnatmake_Mapping_File : String_Access := null; -- The path name of a mapping file specified by switch -C= - procedure Init_Mapping_File (File_Index : in out Natural); + procedure Init_Mapping_File (File_Index : out Natural); -- Create a new mapping file or reuse one already created. package Temp_File_Paths is new Table.Table @@ -1421,9 +1424,9 @@ package body Make is -------------------------- procedure Check_Linker_Options - (E_Stamp : Time_Stamp_Type; - O_File : out File_Name_Type; - O_Stamp : out Time_Stamp_Type) + (E_Stamp : Time_Stamp_Type; + O_File : out File_Name_Type; + O_Stamp : out Time_Stamp_Type) is procedure Check_File (File : File_Name_Type); -- Update O_File and O_Stamp if the given file is younger than E_Stamp @@ -1865,9 +1868,9 @@ package body Make is if Add_It then if not Queue.Insert - ((File => Sfile, - Unit => No_Unit_Name, - Index => 0)) + ((File => Sfile, + Unit => No_Unit_Name, + Index => 0)) then if Is_In_Obsoleted (Sfile) then Executable_Obsolete := True; @@ -2347,10 +2350,10 @@ package body Make is Full_Lib_File : File_Name_Type := No_File; Lib_File_Attr : aliased File_Attributes; Read_Only : Boolean := False; - ALI : ALI_Id; + ALI : ALI_Id := No_ALI_Id; -- The ALI file and its attributes (size, stamp, ...) - Obj_File : File_Name_Type; + Obj_File : File_Name_Type := No_File; Obj_Stamp : Time_Stamp_Type; -- The object file @@ -3614,7 +3617,7 @@ package body Make is -- Init_Mapping_File -- ----------------------- - procedure Init_Mapping_File (File_Index : in out Natural) is + procedure Init_Mapping_File (File_Index : out Natural) is FD : File_Descriptor; Status : Boolean; -- For call to Close @@ -4378,9 +4381,7 @@ package body Make is Look_In_Primary_Dir := False; elsif Program_Args = Compiler then - if Argv (3 .. Argv'Last) /= "-" then - Add_Source_Search_Dir (Argv (3 .. Argv'Last)); - end if; + Add_Source_Search_Dir (Argv (3 .. Argv'Last)); elsif Program_Args = Binder then Add_Library_Search_Dir (Argv (3 .. Argv'Last)); @@ -4690,7 +4691,8 @@ package body Make is -- -m - elsif Argv (2) = 'm' and then Argv'Last = 2 then + elsif Argv (2) = 'm' then + pragma Assert (Argv'Last = 2); Minimal_Recompilation := True; -- -u diff --git a/gcc/ada/make.ads b/gcc/ada/make.ads index 117f5ed..4cd346a 100644 --- a/gcc/ada/make.ads +++ b/gcc/ada/make.ads @@ -29,6 +29,7 @@ package Make is procedure Gnatmake; + pragma No_Return (Gnatmake); -- The driver of gnatmake. For more information on gnatmake and its -- precise usage please refer to the gnat documentation. diff --git a/gcc/ada/make_util.ads b/gcc/ada/make_util.ads index bdf5796..9c7bb4d 100644 --- a/gcc/ada/make_util.ads +++ b/gcc/ada/make_util.ads @@ -184,11 +184,13 @@ package Make_Util is procedure Fail_Program (S : String; Flush_Messages : Boolean := True); + pragma No_Return (Fail_Program); -- Terminate program with a message and a fatal status code procedure Finish_Program (Exit_Code : Osint.Exit_Code_Type := Osint.E_Success; S : String := ""); + pragma No_Return (Finish_Program); -- Terminate program, with or without a message, setting the status code -- according to Fatal. This properly removes all temporary files. diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index 54f9123..1f12889 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -80,11 +80,11 @@ package body Opt is return Exception_Mechanism = Back_End_ZCX; end ZCX_Exceptions; - ---------------------------------- - -- Register_Opt_Config_Switches -- - ---------------------------------- + ------------------------------ + -- Register_Config_Switches -- + ------------------------------ - procedure Register_Opt_Config_Switches is + procedure Register_Config_Switches is begin Ada_Version_Config := Ada_Version; Ada_Version_Pragma_Config := Ada_Version_Pragma; @@ -118,13 +118,13 @@ package body Opt is -- but that's not a local setting. Optimize_Alignment_Local := False; - end Register_Opt_Config_Switches; + end Register_Config_Switches; - --------------------------------- - -- Restore_Opt_Config_Switches -- - --------------------------------- + ----------------------------- + -- Restore_Config_Switches -- + ----------------------------- - procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type) is + procedure Restore_Config_Switches (Save : Config_Switches_Type) is begin Ada_Version := Save.Ada_Version; Ada_Version_Pragma := Save.Ada_Version_Pragma; @@ -160,48 +160,50 @@ package body Opt is -- Normalize_Scalars then it forces that value for all with'ed units. Init_Or_Norm_Scalars := Initialize_Scalars or Normalize_Scalars; - end Restore_Opt_Config_Switches; + end Restore_Config_Switches; - ------------------------------ - -- Save_Opt_Config_Switches -- - ------------------------------ + -------------------------- + -- Save_Config_Switches -- + -------------------------- - procedure Save_Opt_Config_Switches (Save : out Config_Switches_Type) is + function Save_Config_Switches return Config_Switches_Type is begin - Save.Ada_Version := Ada_Version; - Save.Ada_Version_Pragma := Ada_Version_Pragma; - Save.Ada_Version_Explicit := Ada_Version_Explicit; - Save.Assertions_Enabled := Assertions_Enabled; - Save.Assume_No_Invalid_Values := Assume_No_Invalid_Values; - Save.Check_Float_Overflow := Check_Float_Overflow; - Save.Check_Policy_List := Check_Policy_List; - Save.Default_Pool := Default_Pool; - Save.Default_SSO := Default_SSO; - Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks; - Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed; - Save.Extensions_Allowed := Extensions_Allowed; - Save.External_Name_Exp_Casing := External_Name_Exp_Casing; - Save.External_Name_Imp_Casing := External_Name_Imp_Casing; - Save.Fast_Math := Fast_Math; - Save.Initialize_Scalars := Initialize_Scalars; - Save.No_Component_Reordering := No_Component_Reordering; - Save.Optimize_Alignment := Optimize_Alignment; - Save.Optimize_Alignment_Local := Optimize_Alignment_Local; - Save.Persistent_BSS_Mode := Persistent_BSS_Mode; - Save.Polling_Required := Polling_Required; - Save.Prefix_Exception_Messages := Prefix_Exception_Messages; - Save.SPARK_Mode := SPARK_Mode; - Save.SPARK_Mode_Pragma := SPARK_Mode_Pragma; - Save.Uneval_Old := Uneval_Old; - Save.Use_VADS_Size := Use_VADS_Size; - Save.Warnings_As_Errors_Count := Warnings_As_Errors_Count; - end Save_Opt_Config_Switches; + return + (Ada_Version => Ada_Version, + Ada_Version_Pragma => Ada_Version_Pragma, + Ada_Version_Explicit => Ada_Version_Explicit, + Assertions_Enabled => Assertions_Enabled, + Assume_No_Invalid_Values => Assume_No_Invalid_Values, + Check_Float_Overflow => Check_Float_Overflow, + Check_Policy_List => Check_Policy_List, + Default_Pool => Default_Pool, + Default_SSO => Default_SSO, + Dynamic_Elaboration_Checks => Dynamic_Elaboration_Checks, + Exception_Locations_Suppressed => Exception_Locations_Suppressed, + Extensions_Allowed => Extensions_Allowed, + External_Name_Exp_Casing => External_Name_Exp_Casing, + External_Name_Imp_Casing => External_Name_Imp_Casing, + Fast_Math => Fast_Math, + Initialize_Scalars => Initialize_Scalars, + No_Component_Reordering => No_Component_Reordering, + Normalize_Scalars => Normalize_Scalars, + Optimize_Alignment => Optimize_Alignment, + Optimize_Alignment_Local => Optimize_Alignment_Local, + Persistent_BSS_Mode => Persistent_BSS_Mode, + Polling_Required => Polling_Required, + Prefix_Exception_Messages => Prefix_Exception_Messages, + SPARK_Mode => SPARK_Mode, + SPARK_Mode_Pragma => SPARK_Mode_Pragma, + Uneval_Old => Uneval_Old, + Use_VADS_Size => Use_VADS_Size, + Warnings_As_Errors_Count => Warnings_As_Errors_Count); + end Save_Config_Switches; - ----------------------------- - -- Set_Opt_Config_Switches -- - ----------------------------- + ------------------------- + -- Set_Config_Switches -- + ------------------------- - procedure Set_Opt_Config_Switches + procedure Set_Config_Switches (Internal_Unit : Boolean; Main_Unit : Boolean) is @@ -244,12 +246,14 @@ package body Opt is Check_Policy_List := Check_Policy_List_Config; SPARK_Mode := SPARK_Mode_Config; SPARK_Mode_Pragma := SPARK_Mode_Pragma_Config; + else if GNAT_Mode_Config then Assertions_Enabled := Assertions_Enabled_Config; else Assertions_Enabled := False; end if; + Assume_No_Invalid_Values := False; Check_Policy_List := Empty; SPARK_Mode := None; @@ -299,7 +303,7 @@ package body Opt is Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config; Fast_Math := Fast_Math_Config; Polling_Required := Polling_Required_Config; - end Set_Opt_Config_Switches; + end Set_Config_Switches; --------------- -- Tree_Read -- diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 7e23d1d..fd45984 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -2148,11 +2148,20 @@ package Opt is type Config_Switches_Type is private; -- Type used to save values of the switches set from Config values - procedure Save_Opt_Config_Switches (Save : out Config_Switches_Type); - -- This procedure saves the current values of the switches which are - -- initialized from the above Config values. + procedure Register_Config_Switches; + -- This procedure is called after processing the gnat.adc file and other + -- configuration pragma files to record the values of the Config switches, + -- as possibly modified by the use of command line switches and pragmas + -- appearing in these files. + + procedure Restore_Config_Switches (Save : Config_Switches_Type); + -- This procedure restores a set of switch values previously saved by a + -- call to Save_Config_Switches. + + function Save_Config_Switches return Config_Switches_Type; + -- Return the current state of all configuration-related attributes - procedure Set_Opt_Config_Switches + procedure Set_Config_Switches (Internal_Unit : Boolean; Main_Unit : Boolean); -- This procedure sets the switches to the appropriate initial values. The @@ -2164,16 +2173,6 @@ package Opt is -- internal unit is the main unit, in which case we use the command line -- settings. - procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type); - -- This procedure restores a set of switch values previously saved by a - -- call to Save_Opt_Config_Switches (Save). - - procedure Register_Opt_Config_Switches; - -- This procedure is called after processing the gnat.adc file and other - -- configuration pragma files to record the values of the Config switches, - -- as possibly modified by the use of command line switches and pragmas - -- appearing in these files. - ------------------------ -- Other Global Flags -- ------------------------ diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 070dd6d..dd6c9b6 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -57,22 +57,22 @@ with Tbuild; use Tbuild; function Par (Configuration_Pragmas : Boolean) return List_Id is + Inside_Record_Definition : Boolean := False; + -- True within a record definition. Used to control warning for + -- redefinition of standard entities (not issued for field names). + + Loop_Block_Count : Nat := 0; + -- Counter used for constructing loop/block names (see the routine + -- Par.Ch5.Get_Loop_Block_Name). + Num_Library_Units : Natural := 0; -- Count number of units parsed (relevant only in syntax check only mode, -- since in semantics check mode only a single unit is permitted anyway). - Save_Config_Switches : Config_Switches_Type; + Save_Config_Attrs : Config_Switches_Type; -- Variable used to save values of config switches while we parse the -- new unit, to be restored on exit for proper recursive behavior. - Loop_Block_Count : Nat := 0; - -- Counter used for constructing loop/block names (see the routine - -- Par.Ch5.Get_Loop_Block_Name). - - Inside_Record_Definition : Boolean := False; - -- True within a record definition. Used to control warning for - -- redefinition of standard entities (not issued for field names). - -------------------- -- Error Recovery -- -------------------- @@ -1517,7 +1517,7 @@ begin -- Normal case of compilation unit else - Save_Opt_Config_Switches (Save_Config_Switches); + Save_Config_Attrs := Save_Config_Switches; -- The following loop runs more than once in syntax check mode -- where we allow multiple compilation units in the same file @@ -1525,7 +1525,7 @@ begin -- we get to the unit we want. for Ucount in Pos loop - Set_Opt_Config_Switches + Set_Config_Switches (Is_Internal_Unit (Current_Source_Unit), Main_Unit => Current_Source_Unit = Main_Unit); @@ -1661,7 +1661,7 @@ begin end if; - Restore_Opt_Config_Switches (Save_Config_Switches); + Restore_Config_Switches (Save_Config_Attrs); end loop; -- Now that we have completely parsed the source file, we can complete @@ -1690,7 +1690,7 @@ begin -- Restore settings of switches saved on entry - Restore_Opt_Config_Switches (Save_Config_Switches); + Restore_Config_Switches (Save_Config_Attrs); Set_Comes_From_Source_Default (False); end if; diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index 7558414..5c2cc43 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -106,8 +106,9 @@ __gnat_Unwind_RaiseException (_Unwind_Exception *); _Unwind_Reason_Code __gnat_Unwind_ForcedUnwind (_Unwind_Exception *, _Unwind_Stop_Fn, void *); -extern struct Exception_Occurrence *__gnat_setup_current_excep - (_Unwind_Exception *); +extern struct Exception_Occurrence * +__gnat_setup_current_excep (_Unwind_Exception *, _Unwind_Action); + extern void __gnat_unhandled_except_handler (_Unwind_Exception *); #ifdef CERT @@ -1220,12 +1221,14 @@ personality_body (_Unwind_Action uw_phases, else { #ifndef CERT - struct Exception_Occurrence *excep; - /* Trigger the appropriate notification routines before the second - phase starts, which ensures the stack is still intact. - First, setup the Ada occurrence. */ - excep = __gnat_setup_current_excep (uw_exception); + phase starts, when the stack is still intact. First install what + needs to be installed in the current exception buffer and fetch + the Ada occurrence pointer to use. */ + + struct Exception_Occurrence *excep + = __gnat_setup_current_excep (uw_exception, uw_phases); + if (action.kind == unhandler) __gnat_notify_unhandled_exception (excep); else @@ -1245,10 +1248,10 @@ personality_body (_Unwind_Action uw_phases, (uw_context, uw_exception, action.landing_pad, action.ttype_filter); #ifndef CERT - /* Write current exception, so that it can be retrieved from Ada. It was - already done during phase 1 (just above), but in between, one or several - exceptions may have been raised (in cleanup handlers). */ - __gnat_setup_current_excep (uw_exception); + /* Write current exception so that it can be retrieved from Ada. It was + already done during phase 1, but one or several exceptions may have been + raised in cleanup handlers in between. */ + __gnat_setup_current_excep (uw_exception, uw_phases); #endif return _URC_INSTALL_CONTEXT; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 6c8af05..b2bc9ca 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -428,7 +428,7 @@ package body Repinfo is List_Entities (E, Bytes_Big_Endian, True); - elsif Ekind (E) in Formal_Kind and then In_Subprogram then + elsif Is_Formal (E) and then In_Subprogram then null; elsif Ekind_In (E, E_Entry, @@ -1772,11 +1772,15 @@ package body Repinfo is begin if List_Representation_Info_To_JSON then Write_Line (","); - Write_Str (" """ & Attr_Name & """: ""System."); + Write_Str (" """); + Write_Str (Attr_Name); + Write_Str (""": ""System."); else Write_Str ("for "); List_Name (Ent); - Write_Str ("'" & Attr_Name & " use System."); + Write_Char ('''); + Write_Str (Attr_Name); + Write_Str (" use System."); end if; if Bytes_Big_Endian xor Is_Reversed then @@ -1962,10 +1966,8 @@ package body Repinfo is -- Rep_Value -- --------------- - function Rep_Value - (Val : Node_Ref_Or_Val; - D : Discrim_List) return Uint - is + function Rep_Value (Val : Node_Ref_Or_Val; D : Discrim_List) return Uint is + function B (Val : Boolean) return Uint; -- Returns Uint_0 for False, Uint_1 for True diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads index 79f93f9..feda436 100644 --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -379,9 +379,7 @@ package Repinfo is type Discrim_List is array (Pos range <>) of Uint; -- Type used to represent list of discriminant values - function Rep_Value - (Val : Node_Ref_Or_Val; - D : Discrim_List) return Uint; + function Rep_Value (Val : Node_Ref_Or_Val; D : Discrim_List) return Uint; -- Given the contents of a First_Bit_Position or Esize field containing -- a node reference (i.e. a negative Uint value) and D, the list of -- discriminant values, returns the interpreted value of this field. diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index ca87496..2415ef8 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -36,7 +36,6 @@ with Nlists; use Nlists; with Output; use Output; with Restrict; use Restrict; with Sem_Attr; use Sem_Attr; -with Sem_Aux; use Sem_Aux; with Sem_Ch2; use Sem_Ch2; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; @@ -1439,7 +1438,7 @@ package body Sem is In_Extended_Main_Source_Unit (Comp_Unit); -- Determine if unit is in extended main source unit - Save_Config_Switches : Config_Switches_Type; + Save_Config_Attrs : Config_Switches_Type; -- Variable used to save values of config switches while we analyze the -- new unit, to be restored on exit for proper recursive behavior. @@ -1448,9 +1447,18 @@ package body Sem is -- unit. All with'ed units are analyzed with config restrictions reset -- and we need to restore these saved values at the end. + Save_Preanalysis_Counter : constant Nat := + Inside_Preanalysis_Without_Freezing; + -- Saves the preanalysis nesting-level counter; required since we may + -- need to analyze a unit as a consequence of the preanalysis of an + -- expression without freezing (and the loaded unit must be fully + -- analyzed). + -- Start of processing for Semantics begin + Inside_Preanalysis_Without_Freezing := 0; + if Debug_Unit_Walk then if Already_Analyzed then Write_Str ("(done)"); @@ -1519,8 +1527,8 @@ package body Sem is -- Save current config switches and reset then appropriately - Save_Opt_Config_Switches (Save_Config_Switches); - Set_Opt_Config_Switches + Save_Config_Attrs := Save_Config_Switches; + Set_Config_Switches (Is_Internal_Unit (Current_Sem_Unit), Is_Main_Unit_Or_Main_Unit_Spec); @@ -1603,7 +1611,7 @@ package body Sem is Outer_Generic_Scope := S_Outer_Gen_Scope; Style_Check := S_Style_Check; - Restore_Opt_Config_Switches (Save_Config_Switches); + Restore_Config_Switches (Save_Config_Attrs); -- Deal with restore of restrictions @@ -1623,6 +1631,8 @@ package body Sem is Unit (Comp_Unit), Prefix => "<-- "); end if; + + Inside_Preanalysis_Without_Freezing := Save_Preanalysis_Counter; end Semantics; -------- @@ -1705,7 +1715,7 @@ package body Sem is -- The main unit and its spec may depend on bodies that contain generics -- that are instantiated in them. Iterate through the corresponding -- contexts before processing main (spec/body) itself, to process bodies - -- that may be present, together with their context. The spec of main + -- that may be present, together with their context. The spec of main -- is processed wherever it appears in the list of units, while the body -- is processed as the last unit in the list. @@ -1779,8 +1789,7 @@ package body Sem is -- A subprogram body must be the main unit - pragma Assert (Acts_As_Spec (CU) - or else CU = Cunit (Main_Unit)); + pragma Assert (Acts_As_Spec (CU) or else CU = Main_CU); null; when N_Function_Instantiation @@ -1941,9 +1950,7 @@ package body Sem is if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) or else Acts_As_Spec (CU) then - if CU = Cunit (Main_Unit) - and then not Do_Main - then + if CU = Main_CU and then not Do_Main then Seen (Unit_Num) := False; else @@ -2018,10 +2025,9 @@ package body Sem is -- parents that are instances have been loaded already. if Present (Body_CU) - and then Body_CU /= Cunit (Main_Unit) + and then Body_CU /= Main_CU and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body - and then (Nkind (Unit (Comp)) /= N_Package_Declaration - or else Present (Withed_Body (Clause))) + and then Nkind (Unit (Comp)) /= N_Package_Declaration then Body_U := Get_Cunit_Unit_Number (Body_CU); @@ -2154,6 +2160,7 @@ package body Sem is if Par /= Cunit_Entity (Main_Unit) then Do_Unit_And_Dependents (CU, N); end if; + end case; end; @@ -2184,15 +2191,13 @@ package body Sem is function Is_Subunit_Of_Main (U : Node_Id) return Boolean is Lib : Node_Id; + begin - if No (U) then - return False; - else + if Present (U) and then Nkind (Unit (U)) = N_Subunit then Lib := Library_Unit (U); - return Nkind (Unit (U)) = N_Subunit - and then - (Lib = Cunit (Main_Unit) - or else Is_Subunit_Of_Main (Lib)); + return Lib = Main_CU or else Is_Subunit_Of_Main (Lib); + else + return False; end if; end Is_Subunit_Of_Main; @@ -2249,8 +2254,14 @@ package body Sem is for Unit_Num in Done'Range loop if not Done (Unit_Num) then - Write_Unit_Info - (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True); + + -- Units with configuration pragmas (.ads files) have empty + -- compilation-unit nodes; skip printing info about them. + + if Present (Cunit (Unit_Num)) then + Write_Unit_Info + (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True); + end if; end if; end loop; @@ -2335,7 +2346,6 @@ package body Sem is Context_Item : Node_Id; Lib_Unit : Node_Id; - Body_CU : Node_Id; begin Context_Item := First (Context_Items (CU)); @@ -2346,30 +2356,6 @@ package body Sem is then Lib_Unit := Library_Unit (Context_Item); Action (Lib_Unit); - - -- If the context item indicates that a package body is needed - -- because of an instantiation in CU, traverse the body now, even - -- if CU is not related to the main unit. If the generic itself - -- appears in a package body, the context item is this body, and - -- it already appears in the traversal order, so we only need to - -- examine the case of a context item being a package declaration. - - if Present (Withed_Body (Context_Item)) - and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration - and then Present (Corresponding_Body (Unit (Lib_Unit))) - then - Body_CU := - Parent - (Unit_Declaration_Node - (Corresponding_Body (Unit (Lib_Unit)))); - - -- A body may have an implicit with on its own spec, in which - -- case we must ignore this context item to prevent looping. - - if Unit (CU) /= Unit (Body_CU) then - Action (Body_CU); - end if; - end if; end if; Context_Item := Next (Context_Item); diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 0d8f41d..58f3f05 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -286,6 +286,11 @@ package Sem is -- freezing nodes can modify the status of this flag, any other client -- should regard it as read-only. + Inside_Preanalysis_Without_Freezing : Nat := 0; + -- Flag indicating whether we are preanalyzing an expression performing no + -- freezing. Non-zero means we are inside (it is actually a level counter + -- to deal with nested calls). + Unloaded_Subunits : Boolean := False; -- This flag is set True if we have subunits that are not loaded. This -- occurs when the main unit is a subunit, and contains lower level diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 357fbde..39ed046 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1624,7 +1624,7 @@ package body Sem_Ch10 is -- Retain and restore the configuration options of the enclosing -- context as the proper body may introduce a set of its own. - Save_Opt_Config_Switches (Opts); + Opts := Save_Config_Switches; -- Indicate that the body of the package exists. If we are doing -- only semantic analysis, the stub stands for the body. If we are @@ -1644,7 +1644,7 @@ package body Sem_Ch10 is Generate_Reference (Nam, Id, 'b'); Analyze_Proper_Body (N, Nam); - Restore_Opt_Config_Switches (Opts); + Restore_Config_Switches (Opts); end if; end Analyze_Package_Body_Stub; @@ -1985,7 +1985,7 @@ package body Sem_Ch10 is -- Retain and restore the configuration options of the enclosing -- context as the proper body may introduce a set of its own. - Save_Opt_Config_Switches (Opts); + Opts := Save_Config_Switches; Set_Scope (Id, Current_Scope); Set_Ekind (Id, E_Protected_Body); @@ -2000,7 +2000,7 @@ package body Sem_Ch10 is Generate_Reference (Nam, Id, 'b'); Analyze_Proper_Body (N, Etype (Nam)); - Restore_Opt_Config_Switches (Opts); + Restore_Config_Switches (Opts); end if; end Analyze_Protected_Body_Stub; @@ -2045,7 +2045,7 @@ package body Sem_Ch10 is -- Retain and restore the configuration options of the enclosing context -- as the proper body may introduce a set of its own. - Save_Opt_Config_Switches (Opts); + Opts := Save_Config_Switches; -- Treat stub as a body, which checks conformance if there is a previous -- declaration, or else introduces entity and its signature. @@ -2053,7 +2053,7 @@ package body Sem_Ch10 is Analyze_Subprogram_Body (N); Analyze_Proper_Body (N, Empty); - Restore_Opt_Config_Switches (Opts); + Restore_Config_Switches (Opts); end Analyze_Subprogram_Body_Stub; --------------------- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 93a1c12..391d1e3 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1031,23 +1031,18 @@ package body Sem_Ch12 is procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is begin - - -- Add to the instantiation node and the corresponding unit declaration - -- the current values of global flags to be used when analyzing the - -- instance body. + -- Capture the body of the generic instantiation along with its context + -- for later processing by Instantiate_Bodies. Pending_Instantiations.Append - ((Inst_Node => Inst, - Act_Decl => Act_Decl, - Expander_Status => Expander_Active, + ((Act_Decl => Act_Decl, + Config_Switches => Save_Config_Switches, Current_Sem_Unit => Current_Sem_Unit, - Scope_Suppress => Scope_Suppress, + Expander_Status => Expander_Active, + Inst_Node => Inst, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, - Version => Ada_Version, - Version_Pragma => Ada_Version_Pragma, - Warnings => Save_Warnings, - SPARK_Mode => SPARK_Mode, - SPARK_Mode_Pragma => SPARK_Mode_Pragma)); + Scope_Suppress => Scope_Suppress, + Warnings => Save_Warnings)); end Add_Pending_Instantiation; ---------------------------------- @@ -4216,35 +4211,47 @@ package body Sem_Ch12 is else declare - ASN1, ASN2 : Node_Id; + Inherited_Aspects : constant List_Id := + New_Copy_List_Tree + (Aspect_Specifications (Gen_Spec)); + + ASN1 : Node_Id; + ASN2 : Node_Id; + Pool_Present : Boolean := False; begin ASN1 := First (Aspect_Specifications (N)); while Present (ASN1) loop - if Chars (Identifier (ASN1)) = Name_Default_Storage_Pool + if Chars (Identifier (ASN1)) = + Name_Default_Storage_Pool then - -- If generic carries a default storage pool, remove - -- it in favor of the instance one. - - ASN2 := First (Aspect_Specifications (Gen_Spec)); - while Present (ASN2) loop - if Chars (Identifier (ASN2)) = - Name_Default_Storage_Pool - then - Remove (ASN2); - exit; - end if; - - Next (ASN2); - end loop; + Pool_Present := True; + exit; end if; Next (ASN1); end loop; - Prepend_List_To (Aspect_Specifications (N), - (New_Copy_List_Tree - (Aspect_Specifications (Gen_Spec)))); + if Pool_Present then + + -- If generic carries a default storage pool, remove it + -- in favor of the instance one. + + ASN2 := First (Inherited_Aspects); + while Present (ASN2) loop + if Chars (Identifier (ASN2)) = + Name_Default_Storage_Pool + then + Remove (ASN2); + exit; + end if; + + Next (ASN2); + end loop; + end if; + + Prepend_List_To + (Aspect_Specifications (N), Inherited_Aspects); end; end if; end if; @@ -4770,17 +4777,13 @@ package body Sem_Ch12 is Gen_Unit : Entity_Id; Act_Decl : Node_Id) is + Config_Attrs : constant Config_Switches_Type := Save_Config_Switches; + Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); Gen_Comp : constant Entity_Id := Cunit_Entity (Get_Source_Unit (Gen_Unit)); - Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; - Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; - -- Save the SPARK mode-related data to restore on exit. Removing - -- enclosing scopes to provide a clean environment for analysis of - -- the inlined body will eliminate any previously set SPARK_Mode. - Scope_Stack_Depth : constant Pos := Scope_Stack.Last - Scope_Stack.First + 1; @@ -4922,25 +4925,25 @@ package body Sem_Ch12 is pragma Assert (Num_Inner < Num_Scopes); - -- The inlined package body must be analyzed with the SPARK_Mode of - -- the enclosing context, otherwise the body may cause bogus errors - -- if a configuration SPARK_Mode pragma in in effect. - Push_Scope (Standard_Standard); Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True; + + -- The inlined package body is analyzed with the configuration state + -- of the context prior to the scope manipulations performed above. + + -- ??? shouldn't this also use the warning state of the context prior + -- to the scope manipulations? + Instantiate_Package_Body (Body_Info => - ((Inst_Node => N, - Act_Decl => Act_Decl, - Expander_Status => Expander_Active, + ((Act_Decl => Act_Decl, + Config_Switches => Config_Attrs, Current_Sem_Unit => Current_Sem_Unit, - Scope_Suppress => Scope_Suppress, + Expander_Status => Expander_Active, + Inst_Node => N, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, - Version => Ada_Version, - Version_Pragma => Ada_Version_Pragma, - Warnings => Save_Warnings, - SPARK_Mode => Saved_SM, - SPARK_Mode_Pragma => Saved_SMP)), + Scope_Suppress => Scope_Suppress, + Warnings => Save_Warnings)), Inlined_Body => True); Pop_Scope; @@ -5047,17 +5050,14 @@ package body Sem_Ch12 is else Instantiate_Package_Body (Body_Info => - ((Inst_Node => N, - Act_Decl => Act_Decl, - Expander_Status => Expander_Active, + ((Act_Decl => Act_Decl, + Config_Switches => Save_Config_Switches, Current_Sem_Unit => Current_Sem_Unit, - Scope_Suppress => Scope_Suppress, + Expander_Status => Expander_Active, + Inst_Node => N, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, - Version => Ada_Version, - Version_Pragma => Ada_Version_Pragma, - Warnings => Save_Warnings, - SPARK_Mode => SPARK_Mode, - SPARK_Mode_Pragma => SPARK_Mode_Pragma)), + Scope_Suppress => Scope_Suppress, + Warnings => Save_Warnings)), Inlined_Body => True); end if; end Inline_Instance_Body; @@ -8982,7 +8982,7 @@ package body Sem_Ch12 is -- Save configuration switches. These may be reset if the unit is a -- predefined unit, and the current mode is not Ada 2005. - Save_Opt_Config_Switches (Saved.Switches); + Saved.Switches := Save_Config_Switches; Instance_Envs.Append (Saved); @@ -9527,9 +9527,13 @@ package body Sem_Ch12 is -- the freeze node for Inst must be inserted after that of -- Parent_Inst. This relation is established by comparing -- the Slocs of Parent_Inst freeze node and Inst. + -- We examine the parents of the enclosing lists to handle + -- the case where the parent instance is in the visible part + -- of a package declaration, and the inner instance is in + -- the corresponding private part. - if List_Containing (Get_Unit_Instantiation_Node (Par)) = - List_Containing (N) + if Parent (List_Containing (Get_Unit_Instantiation_Node (Par))) + = Parent (List_Containing (N)) and then Sloc (Freeze_Node (Par)) < Sloc (N) then Insert_Freeze_Node_For_Instance (N, F_Node); @@ -11318,13 +11322,9 @@ package body Sem_Ch12 is Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; Scope_Suppress := Body_Info.Scope_Suppress; - Opt.Ada_Version := Body_Info.Version; - Opt.Ada_Version_Pragma := Body_Info.Version_Pragma; - Restore_Warnings (Body_Info.Warnings); - - -- Install the SPARK mode which applies to the package body - Install_SPARK_Mode (Body_Info.SPARK_Mode, Body_Info.SPARK_Mode_Pragma); + Restore_Config_Switches (Body_Info.Config_Switches); + Restore_Warnings (Body_Info.Warnings); if No (Gen_Body_Id) then @@ -11678,15 +11678,9 @@ package body Sem_Ch12 is Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; Scope_Suppress := Body_Info.Scope_Suppress; - Opt.Ada_Version := Body_Info.Version; - Opt.Ada_Version_Pragma := Body_Info.Version_Pragma; - Restore_Warnings (Body_Info.Warnings); - - -- Install the SPARK mode which applies to the subprogram body from the - -- instantiation context. This may be refined further if an explicit - -- SPARK_Mode pragma applies to the generic body. - Install_SPARK_Mode (Body_Info.SPARK_Mode, Body_Info.SPARK_Mode_Pragma); + Restore_Config_Switches (Body_Info.Config_Switches); + Restore_Warnings (Body_Info.Warnings); if No (Gen_Body_Id) then @@ -13719,20 +13713,17 @@ package body Sem_Ch12 is Decl := First_Elmt (Previous_Instances); while Present (Decl) loop Info := - (Inst_Node => Node (Decl), - Act_Decl => + (Act_Decl => Instance_Spec (Node (Decl)), - Expander_Status => Exp_Status, + Config_Switches => Save_Config_Switches, Current_Sem_Unit => Get_Code_Unit (Sloc (Node (Decl))), - Scope_Suppress => Scope_Suppress, + Expander_Status => Exp_Status, + Inst_Node => Node (Decl), Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, - Version => Ada_Version, - Version_Pragma => Ada_Version_Pragma, - Warnings => Save_Warnings, - SPARK_Mode => SPARK_Mode, - SPARK_Mode_Pragma => SPARK_Mode_Pragma); + Scope_Suppress => Scope_Suppress, + Warnings => Save_Warnings); -- Package instance @@ -13782,18 +13773,15 @@ package body Sem_Ch12 is Instantiate_Package_Body (Body_Info => - ((Inst_Node => Inst_Node, - Act_Decl => True_Parent, + ((Act_Decl => True_Parent, + Config_Switches => Save_Config_Switches, + Current_Sem_Unit => + Get_Code_Unit (Sloc (Inst_Node)), Expander_Status => Exp_Status, - Current_Sem_Unit => Get_Code_Unit - (Sloc (Inst_Node)), - Scope_Suppress => Scope_Suppress, + Inst_Node => Inst_Node, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, - Version => Ada_Version, - Version_Pragma => Ada_Version_Pragma, - Warnings => Save_Warnings, - SPARK_Mode => SPARK_Mode, - SPARK_Mode_Pragma => SPARK_Mode_Pragma)), + Scope_Suppress => Scope_Suppress, + Warnings => Save_Warnings)), Body_Optional => Body_Optional); end; end if; @@ -14389,7 +14377,7 @@ package body Sem_Ch12 is Parent_Unit_Visible := Saved.Parent_Unit_Visible; Instance_Parent_Unit := Saved.Instance_Parent_Unit; - Restore_Opt_Config_Switches (Saved.Switches); + Restore_Config_Switches (Saved.Switches); Instance_Envs.Decrement_Last; end Restore_Env; @@ -15964,11 +15952,10 @@ package body Sem_Ch12 is Act_Unit : Entity_Id) is Saved_AE : constant Boolean := Assertions_Enabled; + Saved_CPL : constant Node_Id := Check_Policy_List; + Saved_DEC : constant Boolean := Dynamic_Elaboration_Checks; Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; - -- Save the SPARK mode-related data because utilizing the configuration - -- values of pragmas and switches will eliminate any previously set - -- SPARK_Mode. begin -- Regardless of the current mode, predefined units are analyzed in the @@ -15977,20 +15964,20 @@ package body Sem_Ch12 is -- These are always analyzed in the current mode. if In_Internal_Unit (Gen_Unit) then - Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit); - -- In Ada2012 we may want to enable assertions in an instance of a - -- predefined unit, in which case we need to preserve the current - -- setting for the Assertions_Enabled flag. This will become more - -- critical when pre/postconditions are added to predefined units, - -- as is already the case for some numeric libraries. + -- The following call resets all configuration attributes to default + -- or the xxx_Config versions of the attributes when the current sem + -- unit is the main unit. At the same time, internal units must also + -- inherit certain configuration attributes from their context. It + -- is unclear what these two sets are. - if Ada_Version >= Ada_2012 then - Assertions_Enabled := Saved_AE; - end if; + Set_Config_Switches (True, Current_Sem_Unit = Main_Unit); + + -- Reinstall relevant configuration attributes of the context - -- Reinstall the SPARK_Mode which was in effect at the point of - -- instantiation. + Assertions_Enabled := Saved_AE; + Check_Policy_List := Saved_CPL; + Dynamic_Elaboration_Checks := Saved_DEC; Install_SPARK_Mode (Saved_SM, Saved_SMP); end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 145f637..28a3dd8 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -3443,9 +3443,13 @@ package body Sem_Ch13 is -- We do not do this in ASIS mode, as ASIS relies on the -- original node representing the complete expression, when - -- retrieving it through the source aspect table. + -- retrieving it through the source aspect table. Also, we + -- don't do this in GNATprove mode, because it brings no + -- benefit for proof and causes annoynace for flow analysis, + -- which prefers to be as close to the original source code + -- as possible. - if not ASIS_Mode + if not (ASIS_Mode or GNATprove_Mode) and then (Pname = Name_Postcondition or else not Class_Present (Aspect)) then @@ -5327,6 +5331,10 @@ package body Sem_Ch13 is Error_Msg_N ("Bit_Order can only be defined for record type", Nam); + elsif Is_Tagged_Type (U_Ent) and then Is_Derived_Type (U_Ent) then + Error_Msg_N + ("Bit_Order cannot be defined for record extensions", Nam); + elsif Duplicate_Clause then null; @@ -5340,10 +5348,8 @@ package body Sem_Ch13 is Flag_Non_Static_Expr ("Bit_Order requires static expression!", Expr); - else - if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then - Set_Reverse_Bit_Order (Base_Type (U_Ent), True); - end if; + elsif (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then + Set_Reverse_Bit_Order (Base_Type (U_Ent), True); end if; end if; @@ -11110,13 +11116,27 @@ package body Sem_Ch13 is -- If we have a type with predicates, build predicate function. This is -- not needed in the generic case, nor within TSS subprograms and other - -- predefined primitives. + -- predefined primitives. For a derived type, ensure that the parent + -- type is already frozen so that its predicate function has been + -- constructed already. This is necessary if the parent is declared + -- in a nested package and its own freeze point has not been reached. if Is_Type (E) and then Nongeneric_Case and then not Within_Internal_Subprogram and then Has_Predicates (E) then + declare + Atyp : constant Entity_Id := Nearest_Ancestor (E); + begin + if Present (Atyp) + and then Has_Predicates (Atyp) + and then not Is_Frozen (Atyp) + then + Freeze_Before (N, Atyp); + end if; + end; + Build_Predicate_Functions (E, N); end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b9186d7..349ece7 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -605,6 +605,10 @@ package body Sem_Ch3 is -- Create a new ordinary fixed point type, and apply the constraint to -- obtain subtype of it. + procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id); + -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that + -- In_Default_Expr can be properly adjusted. + procedure Prepare_Private_Subtype_Completion (Id : Entity_Id; Related_Nod : Node_Id); @@ -18615,11 +18619,13 @@ package body Sem_Ch3 is -- A named subtype does not inherit the predicate function of its -- parent but an itype declared for a loop index needs the discrete -- predicate information of its parent to execute the loop properly. + -- A non-discrete type may has a static predicate (for example True) + -- but has no static_discrete_predicate. if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par)); - if Has_Static_Predicate (Par) then + if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then Set_Static_Discrete_Predicate (Subt, Static_Discrete_Predicate (Par)); end if; @@ -19816,11 +19822,17 @@ package body Sem_Ch3 is ----------------------------------- procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is - Save_In_Default_Expr : constant Boolean := In_Default_Expr; + Save_In_Default_Expr : constant Boolean := In_Default_Expr; + Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; + begin - In_Default_Expr := True; - Preanalyze_Spec_Expression (N, T); - In_Default_Expr := Save_In_Default_Expr; + In_Default_Expr := True; + In_Spec_Expression := True; + + Preanalyze_With_Freezing_And_Resolve (N, T); + + In_Default_Expr := Save_In_Default_Expr; + In_Spec_Expression := Save_In_Spec_Expression; end Preanalyze_Default_Expression; -------------------------------- @@ -20125,7 +20137,7 @@ package body Sem_Ch3 is end if; end if; - -- A discriminant cannot be effectively volatile (SPARK RM 7.1.3(6)). + -- A discriminant cannot be effectively volatile (SPARK RM 7.1.3(4)). -- This check is relevant only when SPARK_Mode is on as it is not a -- standard Ada legality rule. diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 2e16917..70daae8 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -236,6 +236,10 @@ package Sem_Ch3 is -- Always False in Ada 95 mode. Equivalent to OK_For_Limited_Init_In_05 in -- Ada 2005 mode. + procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id); + -- Wrapper on Preanalyze_Spec_Expression for assertion expressions, so that + -- In_Assertion_Expr can be properly adjusted. + procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id); -- Default and per object expressions do not freeze their components, and -- must be analyzed and resolved accordingly. The analysis is done by @@ -246,14 +250,6 @@ package Sem_Ch3 is -- This mechanism is also used for aspect specifications that have an -- expression parameter that needs similar preanalysis. - procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id); - -- Wrapper on Preanalyze_Spec_Expression for assertion expressions, so that - -- In_Assertion_Expr can be properly adjusted. - - procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id); - -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that - -- In_Default_Expr can be properly adjusted. - procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id); -- Process some semantic actions when the full view of a private type is -- encountered and analyzed. The first action is to create the full views diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 1b8d8cb..5176175 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3031,15 +3031,9 @@ package body Sem_Ch4 is Analyze_Expression (L); if No (R) then - if Ada_Version >= Ada_2012 then - Analyze_Set_Membership; - Check_Function_Writable_Actuals (N); - else - Error_Msg_N - ("multiple choices in membership tests only allowed in Ada 2012", - N); - end if; - + pragma Assert (Ada_Version >= Ada_2012); + Analyze_Set_Membership; + Check_Function_Writable_Actuals (N); return; end if; @@ -8934,45 +8928,80 @@ package body Sem_Ch4 is (Anc_Type : Entity_Id; Error : out Boolean) is - Cls_Type : Entity_Id; - Hom : Entity_Id; - Hom_Ref : Node_Id; - Success : Boolean; + function First_Formal_Match + (Subp_Id : Entity_Id; + Typ : Entity_Id) return Boolean; + -- Predicate to verify that the first foramal of class-wide + -- subprogram Subp_Id matches type Typ of the prefix. + + ------------------------ + -- First_Formal_Match -- + ------------------------ + + function First_Formal_Match + (Subp_Id : Entity_Id; + Typ : Entity_Id) return Boolean + is + Ctrl : constant Entity_Id := First_Formal (Subp_Id); - begin - Error := False; + begin + return + Present (Ctrl) + and then + (Base_Type (Etype (Ctrl)) = Typ + or else + (Ekind (Etype (Ctrl)) = E_Anonymous_Access_Type + and then + Base_Type (Designated_Type (Etype (Ctrl))) = + Typ)); + end First_Formal_Match; - Cls_Type := Class_Wide_Type (Anc_Type); + -- Local variables - Hom := Current_Entity (Subprog); + CW_Typ : constant Entity_Id := Class_Wide_Type (Anc_Type); + + Candidate : Entity_Id; + -- If homonym is a renaming, examine the renamed program + + Hom : Entity_Id; + Hom_Ref : Node_Id; + Success : Boolean; + + -- Start of processing for Traverse_Homonyms + + begin + Error := False; -- Find a non-hidden operation whose first parameter is of the -- class-wide type, a subtype thereof, or an anonymous access -- to same. If in an instance, the operation can be considered -- even if hidden (it may be hidden because the instantiation -- is expanded after the containing package has been analyzed). + -- If the subprogram is a generic actual in an enclosing instance, + -- it appears as a renaming that is a candidate interpretation as + -- well. + Hom := Current_Entity (Subprog); while Present (Hom) loop if Ekind_In (Hom, E_Procedure, E_Function) - and then (not Is_Hidden (Hom) or else In_Instance) - and then Scope (Hom) = Scope (Base_Type (Anc_Type)) - and then Present (First_Formal (Hom)) - and then - (Base_Type (Etype (First_Formal (Hom))) = Cls_Type - or else - (Is_Access_Type (Etype (First_Formal (Hom))) - and then - Ekind (Etype (First_Formal (Hom))) = - E_Anonymous_Access_Type - and then - Base_Type - (Designated_Type (Etype (First_Formal (Hom)))) = - Cls_Type)) + and then Present (Renamed_Entity (Hom)) + and then Is_Generic_Actual_Subprogram (Hom) + and then In_Open_Scopes (Scope (Hom)) + then + Candidate := Renamed_Entity (Hom); + else + Candidate := Hom; + end if; + + if Ekind_In (Candidate, E_Function, E_Procedure) + and then (not Is_Hidden (Candidate) or else In_Instance) + and then Scope (Candidate) = Scope (Base_Type (Anc_Type)) + and then First_Formal_Match (Candidate, CW_Typ) then -- If the context is a procedure call, ignore functions -- in the name of the call. - if Ekind (Hom) = E_Function + if Ekind (Candidate) = E_Function and then Nkind (Parent (N)) = N_Procedure_Call_Statement and then N = Name (Parent (N)) then @@ -8981,37 +9010,37 @@ package body Sem_Ch4 is -- If the context is a function call, ignore procedures -- in the name of the call. - elsif Ekind (Hom) = E_Procedure + elsif Ekind (Candidate) = E_Procedure and then Nkind (Parent (N)) /= N_Procedure_Call_Statement then goto Next_Hom; end if; - Set_Etype (Call_Node, Any_Type); + Set_Etype (Call_Node, Any_Type); Set_Is_Overloaded (Call_Node, False); Success := False; if No (Matching_Op) then - Hom_Ref := New_Occurrence_Of (Hom, Sloc (Subprog)); - Set_Etype (Call_Node, Any_Type); - Set_Parent (Call_Node, Parent (Node_To_Replace)); + Hom_Ref := New_Occurrence_Of (Candidate, Sloc (Subprog)); - Set_Name (Call_Node, Hom_Ref); + Set_Etype (Call_Node, Any_Type); + Set_Name (Call_Node, Hom_Ref); + Set_Parent (Call_Node, Parent (Node_To_Replace)); Analyze_One_Call (N => Call_Node, - Nam => Hom, + Nam => Candidate, Report => Report_Error, Success => Success, Skip_First => True); Matching_Op := - Valid_Candidate (Success, Call_Node, Hom); + Valid_Candidate (Success, Call_Node, Candidate); else Analyze_One_Call (N => Call_Node, - Nam => Hom, + Nam => Candidate, Report => Report_Error, Success => Success, Skip_First => True); @@ -9020,9 +9049,10 @@ package body Sem_Ch4 is -- traversals, before and after looking at interfaces. -- Check for this case before reporting a real ambiguity. - if Present (Valid_Candidate (Success, Call_Node, Hom)) + if Present + (Valid_Candidate (Success, Call_Node, Candidate)) and then Nkind (Call_Node) /= N_Function_Call - and then Hom /= Matching_Op + and then Candidate /= Matching_Op then Error_Msg_NE ("ambiguous call to&", N, Hom); Report_Ambiguity (Matching_Op); @@ -9484,6 +9514,23 @@ package body Sem_Ch4 is Present (Original_Protected_Subprogram (Prim_Op)) and then Chars (Original_Protected_Subprogram (Prim_Op)) = Chars (Subprog); + + -- In an instance, the selector name may be a generic actual that + -- renames a primitive operation of the type of the prefix. + + elsif In_Instance and then Present (Current_Entity (Subprog)) then + declare + Subp : constant Entity_Id := Current_Entity (Subprog); + begin + if Present (Subp) + and then Is_Subprogram (Subp) + and then Present (Renamed_Entity (Subp)) + and then Is_Generic_Actual_Subprogram (Subp) + and then Chars (Renamed_Entity (Subp)) = Chars (Prim_Op) + then + return True; + end if; + end; end if; return False; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 3ce57ea..f35b37d 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -83,6 +83,12 @@ package body Sem_Ch5 is -- messages. This variable is recursively saved on entry to processing the -- construct, and restored on exit. + function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; + -- N is the node for an arbitrary construct. This function searches the + -- construct N to see if any expressions within it contain function + -- calls that use the secondary stack, returning True if any such call + -- is found, and False otherwise. + procedure Preanalyze_Range (R_Copy : Node_Id); -- Determine expected type of range or domain of iteration of Ada 2012 -- loop by analyzing separate copy. Do the analysis and resolution of the @@ -2692,12 +2698,6 @@ package body Sem_Ch5 is -- forms. In this case it is not sufficent to check the static predicate -- function only, look for a dynamic predicate aspect as well. - function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; - -- N is the node for an arbitrary construct. This function searches the - -- construct N to see if any expressions within it contain function - -- calls that use the secondary stack, returning True if any such call - -- is found, and False otherwise. - procedure Process_Bounds (R : Node_Id); -- If the iteration is given by a range, create temporaries and -- assignment statements block to capture the bounds and perform @@ -2782,65 +2782,6 @@ package body Sem_Ch5 is end if; end Check_Predicate_Use; - ------------------------------------ - -- Has_Call_Using_Secondary_Stack -- - ------------------------------------ - - function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is - function Check_Call (N : Node_Id) return Traverse_Result; - -- Check if N is a function call which uses the secondary stack - - ---------------- - -- Check_Call -- - ---------------- - - function Check_Call (N : Node_Id) return Traverse_Result is - Nam : Node_Id; - Subp : Entity_Id; - Typ : Entity_Id; - - begin - if Nkind (N) = N_Function_Call then - Nam := Name (N); - - -- Obtain the subprogram being invoked - - loop - if Nkind (Nam) = N_Explicit_Dereference then - Nam := Prefix (Nam); - - elsif Nkind (Nam) = N_Selected_Component then - Nam := Selector_Name (Nam); - - else - exit; - end if; - end loop; - - Subp := Entity (Nam); - Typ := Etype (Subp); - - if Requires_Transient_Scope (Typ) then - return Abandon; - - elsif Sec_Stack_Needed_For_Return (Subp) then - return Abandon; - end if; - end if; - - -- Continue traversing the tree - - return OK; - end Check_Call; - - function Check_Calls is new Traverse_Func (Check_Call); - - -- Start of processing for Has_Call_Using_Secondary_Stack - - begin - return Check_Calls (N) = Abandon; - end Has_Call_Using_Secondary_Stack; - -------------------- -- Process_Bounds -- -------------------- @@ -3644,6 +3585,58 @@ package body Sem_Ch5 is end; end if; + -- Wrap the loop in a block when the evaluation of the loop iterator + -- relies on the secondary stack. Required to ensure releasing the + -- secondary stack as soon as the loop completes. + + if Present (Iter) + and then Present (Loop_Parameter_Specification (Iter)) + and then not Is_Wrapped_In_Block (N) + then + declare + LPS : constant Node_Id := Loop_Parameter_Specification (Iter); + DSD : constant Node_Id := + Original_Node (Discrete_Subtype_Definition (LPS)); + + Block_Id : Entity_Id; + Block_Nod : Node_Id; + HB : Node_Id; + LB : Node_Id; + + begin + if Nkind (DSD) = N_Subtype_Indication + and then Nkind (Range_Expression (Constraint (DSD))) = N_Range + then + LB := + New_Copy_Tree + (Low_Bound (Range_Expression (Constraint (DSD)))); + HB := + New_Copy_Tree + (High_Bound (Range_Expression (Constraint (DSD)))); + + Preanalyze (LB); + Preanalyze (HB); + + if Has_Call_Using_Secondary_Stack (LB) + or else Has_Call_Using_Secondary_Stack (HB) + then + Block_Nod := + Make_Block_Statement (Loc, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Relocate_Node (N)))); + + Add_Block_Identifier (Block_Nod, Block_Id); + Set_Uses_Sec_Stack (Block_Id); + Rewrite (N, Block_Nod); + Analyze (N); + return; + end if; + end if; + end; + end if; + -- Kill current values on entry to loop, since statements in the body of -- the loop may have been executed before the loop is entered. Similarly -- we kill values after the loop, since we do not know that the body of @@ -4072,6 +4065,65 @@ package body Sem_Ch5 is end if; end Check_Unreachable_Code; + ------------------------------------ + -- Has_Call_Using_Secondary_Stack -- + ------------------------------------ + + function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is + function Check_Call (N : Node_Id) return Traverse_Result; + -- Check if N is a function call which uses the secondary stack + + ---------------- + -- Check_Call -- + ---------------- + + function Check_Call (N : Node_Id) return Traverse_Result is + Nam : Node_Id; + Subp : Entity_Id; + Typ : Entity_Id; + + begin + if Nkind (N) = N_Function_Call then + Nam := Name (N); + + -- Obtain the subprogram being invoked + + loop + if Nkind (Nam) = N_Explicit_Dereference then + Nam := Prefix (Nam); + + elsif Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); + + else + exit; + end if; + end loop; + + Subp := Entity (Nam); + Typ := Etype (Subp); + + if Requires_Transient_Scope (Typ) then + return Abandon; + + elsif Sec_Stack_Needed_For_Return (Subp) then + return Abandon; + end if; + end if; + + -- Continue traversing the tree + + return OK; + end Check_Call; + + function Check_Calls is new Traverse_Func (Check_Call); + + -- Start of processing for Has_Call_Using_Secondary_Stack + + begin + return Check_Calls (N) = Abandon; + end Has_Call_Using_Secondary_Stack; + ---------------------- -- Preanalyze_Range -- ---------------------- diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 3413e21..2dd9d2f 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -206,6 +206,10 @@ package body Sem_Ch6 is -- Create the declaration for an inequality operator that is implicitly -- created by a user-defined equality operator that yields a boolean. + procedure Preanalyze_Formal_Expression (N : Node_Id; T : Entity_Id); + -- Preanalysis of default expressions of subprogram formals. N is the + -- expression to be analyzed and T is the expected type. + procedure Set_Formal_Validity (Formal_Id : Entity_Id); -- Formal_Id is an formal parameter entity. This procedure deals with -- setting the proper validity status for this entity, which depends on @@ -761,7 +765,7 @@ package body Sem_Ch6 is if not Inside_A_Generic then Push_Scope (Def_Id); Install_Formals (Def_Id); - Preanalyze_Spec_Expression (Expr, Typ); + Preanalyze_Formal_Expression (Expr, Typ); Check_Limited_Return (Original_Node (N), Expr, Typ); End_Scope; end if; @@ -2712,6 +2716,22 @@ package body Sem_Ch6 is Specification => Copy_Subprogram_Spec (Body_Spec)); Set_Comes_From_Source (Subp_Decl, True); + -- Also mark parameters as coming from source + + if Present (Parameter_Specifications (Specification (Subp_Decl))) then + declare + Form : Entity_Id; + begin + Form := + First (Parameter_Specifications (Specification (Subp_Decl))); + + while Present (Form) loop + Set_Comes_From_Source (Defining_Identifier (Form), True); + Next (Form); + end loop; + end; + end if; + -- Relocate the aspects and relevant pragmas from the subprogram body -- to the generated spec because it acts as the initial declaration. @@ -3846,12 +3866,14 @@ package body Sem_Ch6 is -- If the subprogram has a class-wide clone, build its body as a copy -- of the original body, and rewrite body of original subprogram as a -- wrapper that calls the clone. If N is a stub, this construction will - -- take place when the proper body is analyzed. + -- take place when the proper body is analyzed. No action needed if this + -- subprogram has been eliminated. if Present (Spec_Id) and then Present (Class_Wide_Clone (Spec_Id)) and then (Comes_From_Source (N) or else Was_Expression_Function (N)) and then Nkind (N) /= N_Subprogram_Body_Stub + and then not (Expander_Active and then Is_Eliminated (Spec_Id)) then Build_Class_Wide_Clone_Body (Spec_Id, N); @@ -8559,14 +8581,10 @@ package body Sem_Ch6 is if Is_Frozen (Typ) then - -- If the type is not declared in a package, or if we are in the body - -- of the package or in some other scope, the new operation is not - -- primitive, and therefore legal, though suspicious. Should we - -- generate a warning in this case ??? + -- The check applies to a primitive operation, so check that type + -- and equality operation are in the same scope. - if Ekind (Scope (Typ)) /= E_Package - or else Scope (Typ) /= Current_Scope - then + if Scope (Typ) /= Current_Scope then return; -- If the type is a generic actual (sub)type, the operation is not @@ -8609,7 +8627,7 @@ package body Sem_Ch6 is ("\move declaration to package spec (Ada 2012)?y?", Eq_Op); end if; - -- Otherwise try to find the freezing point + -- Otherwise try to find the freezing point for better message. else Obj_Decl := Next (Parent (Typ)); @@ -8637,6 +8655,13 @@ package body Sem_Ch6 is end if; exit; + + -- If we reach generated code for subprogram declaration + -- or body, it is the body that froze the type and the + -- declaration is legal. + + elsif Sloc (Obj_Decl) = Sloc (Decl) then + return; end if; Next (Obj_Decl); @@ -11317,6 +11342,18 @@ package body Sem_Ch6 is end if; end New_Overloaded_Entity; + ---------------------------------- + -- Preanalyze_Formal_Expression -- + ---------------------------------- + + procedure Preanalyze_Formal_Expression (N : Node_Id; T : Entity_Id) is + Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; + begin + In_Spec_Expression := True; + Preanalyze_With_Freezing_And_Resolve (N, T); + In_Spec_Expression := Save_In_Spec_Expression; + end Preanalyze_Formal_Expression; + --------------------- -- Process_Formals -- --------------------- @@ -11609,7 +11646,7 @@ package body Sem_Ch6 is -- Do the special preanalysis of the expression (see section on -- "Handling of Default Expressions" in the spec of package Sem). - Preanalyze_Spec_Expression (Default, Formal_Type); + Preanalyze_Formal_Expression (Default, Formal_Type); -- An access to constant cannot be the default for -- an access parameter that is an access to variable. diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 02471d7..f538144 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3782,9 +3782,7 @@ package body Sem_Ch8 is -- Local variables - Ghost_Id : Entity_Id := Empty; - Living_Id : Entity_Id := Empty; - Pack : Entity_Id; + Pack : Entity_Id; -- Start of processing for Analyze_Use_Package @@ -3870,22 +3868,9 @@ package body Sem_Ch8 is end if; Use_One_Package (N, Name (N)); - - -- Capture the first Ghost package and the first living package - - if Is_Entity_Name (Name (N)) then - Pack := Entity (Name (N)); - - if Is_Ghost_Entity (Pack) then - if No (Ghost_Id) then - Ghost_Id := Pack; - end if; - - elsif No (Living_Id) then - Living_Id := Pack; - end if; - end if; end if; + + Mark_Ghost_Clause (N); end Analyze_Use_Package; ---------------------- @@ -5423,8 +5408,6 @@ package body Sem_Ch8 is -- Local variables - Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes; - Nested_Inst : Entity_Id := Empty; -- The entity of a nested instance which appears within Inst (if any) @@ -5970,11 +5953,19 @@ package body Sem_Ch8 is -- reference is a write when it appears on the left hand side of an -- assignment. - if not Within_Subprogram_Call (N) then - Build_Variable_Reference_Marker - (N => N, - Read => not Is_Assignment_LHS, - Write => Is_Assignment_LHS); + if Needs_Variable_Reference_Marker + (N => N, + Calls_OK => False) + then + declare + Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes; + + begin + Build_Variable_Reference_Marker + (N => N, + Read => not Is_Assignment_LHS, + Write => Is_Assignment_LHS); + end; end if; end Find_Direct_Name; @@ -6047,8 +6038,7 @@ package body Sem_Ch8 is -- Local variables - Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes; - Selector : constant Node_Id := Selector_Name (N); + Selector : constant Node_Id := Selector_Name (N); Candidate : Entity_Id := Empty; P_Name : Entity_Id; @@ -6621,11 +6611,19 @@ package body Sem_Ch8 is -- reference is a write when it appears on the left hand side of an -- assignment. - if not Within_Subprogram_Call (N) then - Build_Variable_Reference_Marker - (N => N, - Read => not Is_Assignment_LHS, - Write => Is_Assignment_LHS); + if Needs_Variable_Reference_Marker + (N => N, + Calls_OK => False) + then + declare + Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes; + + begin + Build_Variable_Reference_Marker + (N => N, + Read => not Is_Assignment_LHS, + Write => Is_Assignment_LHS); + end; end if; end Find_Expanded_Name; @@ -8301,7 +8299,6 @@ package body Sem_Ch8 is ---------------------- procedure Mark_Use_Clauses (Id : Node_Or_Entity_Id) is - procedure Mark_Parameters (Call : Entity_Id); -- Perform use_type_clause marking for all parameters in a subprogram -- or operator call. diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index b049930..0919556 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2358,7 +2358,7 @@ package body Sem_Ch9 is if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) and then (not Is_Entity_Name (Target_Obj) - or else Ekind (Entity (Target_Obj)) not in Formal_Kind + or else not Is_Formal (Entity (Target_Obj)) or else Enclosing /= Scope (Entity (Target_Obj))) then Error_Msg_N diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 72bb0cb..8226e10 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -2072,8 +2072,8 @@ package body Sem_Elab is if Legacy_Elaboration_Checks then return; - -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are - -- not performed in this mode. + -- Nothing to do for ASIS because ABE checks and diagnostics are not + -- performed in this mode. elsif ASIS_Mode then return; @@ -2274,166 +2274,16 @@ package body Sem_Elab is Read : Boolean; Write : Boolean) is - function In_Compilation_Instance_Formal_Part - (Nod : Node_Id) return Boolean; - -- Determine whether arbitrary node Nod appears within the formal part - -- of an instantiation which acts as a compilation unit. - - function In_Pragma (Nod : Node_Id) return Boolean; - -- Determine whether arbitrary node Nod appears within a pragma - - ----------------------------------------- - -- In_Compilation_Instance_Formal_Part -- - ----------------------------------------- - - function In_Compilation_Instance_Formal_Part - (Nod : Node_Id) return Boolean - is - Par : Node_Id; - - begin - Par := Nod; - while Present (Par) loop - if Nkind (Par) = N_Generic_Association - and then Nkind (Parent (Par)) in N_Generic_Instantiation - and then Nkind (Parent (Parent (Par))) = N_Compilation_Unit - then - return True; - - -- Prevent the search from going too far - - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; - - Par := Parent (Par); - end loop; - - return False; - end In_Compilation_Instance_Formal_Part; - - --------------- - -- In_Pragma -- - --------------- - - function In_Pragma (Nod : Node_Id) return Boolean is - Par : Node_Id; - - begin - Par := Nod; - while Present (Par) loop - if Nkind (Par) = N_Pragma then - return True; - - -- Prevent the search from going too far - - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; - - Par := Parent (Par); - end loop; - - return False; - end In_Pragma; - - -- Local variables - Marker : Node_Id; - Prag : Node_Id; Var_Attrs : Variable_Attributes; Var_Id : Entity_Id; - -- Start of processing for Build_Variable_Reference_Marker - begin - -- Nothing to do when switch -gnatH (legacy elaboration checking mode - -- enabled) is in effect because the legacy ABE mechanism does not need - -- to carry out this action. - - if Legacy_Elaboration_Checks then - return; - - -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are - -- not performed in this mode. - - elsif ASIS_Mode then - return; - - -- Nothing to do when the reference is being preanalyzed as the marker - -- will be inserted in the wrong place. - - elsif Preanalysis_Active then - return; - - -- Nothing to do when the input does not denote a reference - - elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then - return; - - -- Nothing to do for internally-generated references - - elsif not Comes_From_Source (N) then - return; - - -- Nothing to do when the reference is erroneous, left in a bad state, - -- or does not denote a variable. - - elsif not (Present (Entity (N)) - and then Ekind (Entity (N)) = E_Variable - and then Entity (N) /= Any_Id) - then - return; - - -- Nothing to do when the reference appears within the formal part of - -- an instantiation which acts as compilation unit because there is no - -- proper context for the insertion of the marker. - - -- Performance note: parent traversal - - elsif In_Compilation_Instance_Formal_Part (N) then - return; - end if; - Extract_Variable_Reference_Attributes (Ref => N, Var_Id => Var_Id, Attrs => Var_Attrs); - Prag := SPARK_Pragma (Var_Id); - - if Comes_From_Source (Var_Id) - - -- Both the variable and the reference must appear in SPARK_Mode On - -- regions because this scenario falls under the SPARK rules. - - and then Present (Prag) - and then Get_SPARK_Mode_From_Annotation (Prag) = On - and then Is_SPARK_Mode_On_Node (N) - - -- The reference must not be considered when it appears in a pragma. - -- If the pragma has run-time semantics, then the reference will be - -- reconsidered once the pragma is expanded. - - -- Performance note: parent traversal - - and then not In_Pragma (N) - then - null; - - -- Otherwise the reference is not suitable for ABE processing. This - -- prevents the generation of variable markers which will never play - -- a role in ABE diagnostics. - - else - return; - end if; - - -- At this point it is known that the variable reference will play some - -- role in ABE checks and diagnostics. Create a corresponding variable - -- marker in case the original variable reference is folded or optimized - -- away. - Marker := Make_Variable_Reference_Marker (Sloc (N)); -- Inherit the attributes of the original variable reference @@ -2469,8 +2319,8 @@ package body Sem_Elab is if Legacy_Elaboration_Checks then return; - -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics - -- are performed in this mode. + -- Nothing to do for ASIS because ABE checks and diagnostics are not + -- performed in this mode. elsif ASIS_Mode then return; @@ -4913,7 +4763,6 @@ package body Sem_Elab is and then not Comes_From_Source (N) and then Present (Context) and then Nkind (Context) = N_Handled_Sequence_Of_Statements - and then not Comes_From_Source (N) then return False; end if; @@ -10860,8 +10709,8 @@ package body Sem_Elab is if Legacy_Elaboration_Checks then return; - -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics - -- are performed in this mode. + -- Nothing to do for ASIS because ABE checks and diagnostics are not + -- performed in this mode. elsif ASIS_Mode then return; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 59e8672..4560a51 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -104,7 +104,7 @@ package body Sem_Eval is -- Used to convert unsigned (modular) values for folding logical ops -- The following declarations are used to maintain a cache of nodes that - -- have compile time known values. The cache is maintained only for + -- have compile-time-known values. The cache is maintained only for -- discrete types (the most common case), and is populated by calls to -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value -- since it is possible for the status to change (in particular it is @@ -171,7 +171,7 @@ package body Sem_Eval is -- result is No_Match, then it continues and checks the next element. If -- the result is Match or Non_Static, this result is immediately given -- as the result without checking the rest of the list. Expr can be of - -- discrete, real, or string type and must be a compile time known value + -- discrete, real, or string type and must be a compile-time-known value -- (it is an error to make the call if these conditions are not met). function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id; @@ -231,7 +231,7 @@ package body Sem_Eval is procedure Out_Of_Range (N : Node_Id); -- This procedure is called if it is determined that node N, which appears - -- in a non-static context, is a compile time known value which is outside + -- in a non-static context, is a compile-time-known value which is outside -- its range, i.e. the range of Etype. This is used in contexts where -- this is an illegality if N is static, and should generate a warning -- otherwise. @@ -547,9 +547,15 @@ package body Sem_Eval is -- called in contexts like the expression of a number declaration where -- we certainly want to allow out of range values. + -- We inhibit the warning when expansion is disabled, because the + -- preanalysis of a range of a 64-bit modular type may appear to + -- violate the constraint on non-static Universal_Integer. If there + -- is a true overflow it will be diagnosed during full analysis. + if Etype (N) = Universal_Integer and then Nkind (N) = N_Integer_Literal and then Nkind (Parent (N)) in N_Subexpr + and then Expander_Active and then (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer)) or else @@ -840,7 +846,7 @@ package body Sem_Eval is function Is_Same_Value (L, R : Node_Id) return Boolean; -- Returns True iff L and R represent expressions that definitely have - -- identical (but not necessarily compile time known) values Indeed the + -- identical (but not necessarily compile-time-known) values Indeed the -- caller is expected to have already dealt with the cases of compile -- time known values, so these are not tested here. @@ -1043,7 +1049,7 @@ package body Sem_Eval is then return True; - -- Or if they are compile time known and identical + -- Or if they are compile-time-known and identical elsif Compile_Time_Known_Value (Lf) and then @@ -1192,7 +1198,7 @@ package body Sem_Eval is return Unknown; end if; - -- Case where comparison involves two compile time known values + -- Case where comparison involves two compile-time-known values elsif Compile_Time_Known_Value (L) and then @@ -1515,7 +1521,7 @@ package body Sem_Eval is end if; -- Next attempt is to see if we have an entity compared with a - -- compile time known value, where there is a current value + -- compile-time-known value, where there is a current value -- conditional for the entity which can tell us the result. declare @@ -1667,7 +1673,7 @@ package body Sem_Eval is return False; end if; - -- Otherwise check bounds for compile time known + -- Otherwise check bounds for compile-time-known if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then return False; @@ -1705,33 +1711,50 @@ package body Sem_Eval is end if; -- If we have an entity name, then see if it is the name of a constant - -- and if so, test the corresponding constant value, or the name of - -- an enumeration literal, which is always a constant. + -- and if so, test the corresponding constant value, or the name of an + -- enumeration literal, which is always a constant. if Present (Etype (Op)) and then Is_Entity_Name (Op) then declare - E : constant Entity_Id := Entity (Op); - V : Node_Id; + Ent : constant Entity_Id := Entity (Op); + Val : Node_Id; begin - -- Never known at compile time if it is a packed array value. - -- We might want to try to evaluate these at compile time one - -- day, but we do not make that attempt now. + -- Never known at compile time if it is a packed array value. We + -- might want to try to evaluate these at compile time one day, + -- but we do not make that attempt now. if Is_Packed_Array_Impl_Type (Etype (Op)) then return False; - end if; - if Ekind (E) = E_Enumeration_Literal then + elsif Ekind (Ent) = E_Enumeration_Literal then return True; - elsif Ekind (E) = E_Constant then - V := Constant_Value (E); - return Present (V) and then Compile_Time_Known_Value (V); + elsif Ekind (Ent) = E_Constant then + Val := Constant_Value (Ent); + + if Present (Val) then + + -- Guard against an illegal deferred constant whose full + -- view is initialized with a reference to itself. Treat + -- this case as a value not known at compile time. + + if Is_Entity_Name (Val) and then Entity (Val) = Ent then + return False; + else + return Compile_Time_Known_Value (Val); + end if; + + -- Otherwise, the constant does not have a compile-time-known + -- value. + + else + return False; + end if; end if; end; - -- We have a value, see if it is compile time known + -- We have a value, see if it is compile-time-known else -- Integer literals are worth storing in the cache @@ -1794,7 +1817,7 @@ package body Sem_Eval is end if; end; - -- We have a value, see if it is compile time known + -- We have a value, see if it is compile-time-known else if Compile_Time_Known_Value (Op) then @@ -2616,7 +2639,7 @@ package body Sem_Eval is if List_Length (Expressions (Arr)) >= Lin then Elm := Pick (Expressions (Arr), Lin); - -- If the resulting expression is compile time known, + -- If the resulting expression is compile-time-known, -- then we can rewrite the indexed component with this -- value, being sure to mark the result as non-static. -- We also reset the Sloc, in case this generates an @@ -2671,9 +2694,7 @@ package body Sem_Eval is -- the expander that do not correspond to static expressions. procedure Eval_Integer_Literal (N : Node_Id) is - T : constant Entity_Id := Etype (N); - - function In_Any_Integer_Context return Boolean; + function In_Any_Integer_Context (Context : Node_Id) return Boolean; -- If the literal is resolved with a specific type in a context where -- the expected type is Any_Integer, there are no range checks on the -- literal. By the time the literal is evaluated, it carries the type @@ -2684,44 +2705,54 @@ package body Sem_Eval is -- In_Any_Integer_Context -- ---------------------------- - function In_Any_Integer_Context return Boolean is - Par : constant Node_Id := Parent (N); - K : constant Node_Kind := Nkind (Par); - + function In_Any_Integer_Context (Context : Node_Id) return Boolean is begin -- Any_Integer also appears in digits specifications for real types, -- but those have bounds smaller that those of any integer base type, -- so we can safely ignore these cases. - return Nkind_In (K, N_Number_Declaration, - N_Attribute_Reference, - N_Attribute_Definition_Clause, - N_Modular_Type_Definition, - N_Signed_Integer_Type_Definition); + return + Nkind_In (Context, N_Attribute_Definition_Clause, + N_Attribute_Reference, + N_Modular_Type_Definition, + N_Number_Declaration, + N_Signed_Integer_Type_Definition); end In_Any_Integer_Context; + -- Local variables + + Par : constant Node_Id := Parent (N); + Typ : constant Entity_Id := Etype (N); + -- Start of processing for Eval_Integer_Literal begin - -- If the literal appears in a non-expression context, then it is -- certainly appearing in a non-static context, so check it. This is -- actually a redundant check, since Check_Non_Static_Context would -- check it, but it seems worthwhile to optimize out the call. - -- An exception is made for a literal in an if or case expression + -- Additionally, when the literal appears within an if or case + -- expression it must be checked as well. However, due to the literal + -- appearing within a conditional statement, expansion greatly changes + -- the nature of its context and performing some of the checks within + -- Check_Non_Static_Context on an expanded literal may lead to spurious + -- and misleading warnings. - if (Nkind_In (Parent (N), N_If_Expression, N_Case_Expression_Alternative) + if (Nkind_In (Par, N_Case_Expression_Alternative, N_If_Expression) or else Nkind (Parent (N)) not in N_Subexpr) - and then not In_Any_Integer_Context + and then (not Nkind_In (Par, N_Case_Expression_Alternative, + N_If_Expression) + or else Comes_From_Source (N)) + and then not In_Any_Integer_Context (Par) then Check_Non_Static_Context (N); end if; -- Modular integer literals must be in their base range - if Is_Modular_Integer_Type (T) - and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) + if Is_Modular_Integer_Type (Typ) + and then Is_Out_Of_Range (N, Base_Type (Typ), Assume_Valid => True) then Out_Of_Range (N); end if; @@ -4174,9 +4205,9 @@ package body Sem_Eval is Val : Uint; begin - -- If already in cache, then we know it's compile time known and we can + -- If already in cache, then we know it's compile-time-known and we can -- return the value that was previously stored in the cache since - -- compile time known values cannot change. + -- compile-time-known values cannot change. if CV_Ent.N = N then return CV_Ent.V; @@ -4691,7 +4722,7 @@ package body Sem_Eval is end if; -- If bounds not comparable at compile time, then the bounds of T2 - -- must be compile time known or we cannot answer the query. + -- must be compile-time-known or we cannot answer the query. if not Compile_Time_Known_Value (L2) or else not Compile_Time_Known_Value (H2) @@ -5663,8 +5694,8 @@ package body Sem_Eval is ------------------------- procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is - Typ : constant Entity_Id := Etype (N); Stat : constant Boolean := Is_Static_Expression (N); + Typ : constant Entity_Id := Etype (N); begin -- If we want to raise CE in the condition of a N_Raise_CE node, we @@ -5682,9 +5713,16 @@ package body Sem_Eval is -- Else build an explicit N_Raise_CE else - Rewrite (N, - Make_Raise_Constraint_Error (Sloc (Exp), - Reason => CE_Range_Check_Failed)); + if Nkind (Exp) = N_Raise_Constraint_Error then + Rewrite (N, + Make_Raise_Constraint_Error (Sloc (Exp), + Reason => Reason (Exp))); + else + Rewrite (N, + Make_Raise_Constraint_Error (Sloc (Exp), + Reason => CE_Range_Check_Failed)); + end if; + Set_Raises_Constraint_Error (N); Set_Etype (N, Typ); end if; @@ -6364,7 +6402,7 @@ package body Sem_Eval is pragma Warnings (Off, Assume_Valid); -- For now Assume_Valid is unreferenced since the current implementation - -- always returns Unknown if N is not a compile time known value, but we + -- always returns Unknown if N is not a compile-time-known value, but we -- keep the parameter to allow for future enhancements in which we try -- to get the information in the variable case as well. @@ -6397,7 +6435,7 @@ package body Sem_Eval is -- Never known if this is a generic type, since the bounds of generic -- types are junk. Note that if we only checked for static expressions - -- (instead of compile time known values) below, we would not need this + -- (instead of compile-time-known values) below, we would not need this -- check, because values of a generic type can never be static, but they -- can be known at compile time. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9cfb39c..f1f463c2 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2128,10 +2128,10 @@ package body Sem_Prag is procedure Check_Mode_Restriction_In_Enclosing_Context (Item : Node_Id; Item_Id : Entity_Id); - -- Verify that an item of mode In_Out or Output does not appear as an - -- input in the Global aspect of an enclosing subprogram. If this is - -- the case, emit an error. Item and Item_Id are respectively the - -- item and its entity. + -- Verify that an item of mode In_Out or Output does not appear as + -- an input in the Global aspect of an enclosing subprogram or task + -- unit. If this is the case, emit an error. Item and Item_Id are + -- respectively the item and its entity. procedure Check_Mode_Restriction_In_Function (Mode : Node_Id); -- Mode denotes either In_Out or Output. Depending on the kind of the @@ -2483,16 +2483,28 @@ package body Sem_Prag is Outputs : Elist_Id := No_Elist; begin - -- Traverse the scope stack looking for enclosing subprograms - -- subject to pragma [Refined_]Global. + -- Traverse the scope stack looking for enclosing subprograms or + -- tasks subject to pragma [Refined_]Global. Context := Scope (Subp_Id); while Present (Context) and then Context /= Standard_Standard loop - if Is_Subprogram (Context) + + -- For a single task type, retrieve the corresponding object to + -- which pragma [Refined_]Global is attached. + + if Ekind (Context) = E_Task_Type + and then Is_Single_Concurrent_Type (Context) + then + Context := Anonymous_Object (Context); + end if; + + if (Is_Subprogram (Context) + or else Ekind (Context) = E_Task_Type + or else Is_Single_Task_Object (Context)) and then - (Present (Get_Pragma (Context, Pragma_Global)) - or else - Present (Get_Pragma (Context, Pragma_Refined_Global))) + (Present (Get_Pragma (Context, Pragma_Global)) + or else + Present (Get_Pragma (Context, Pragma_Refined_Global))) then Collect_Subprogram_Inputs_Outputs (Subp_Id => Context, @@ -2501,7 +2513,8 @@ package body Sem_Prag is Global_Seen => Dummy); -- The item is classified as In_Out or Output but appears as - -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)). + -- an Input in an enclosing subprogram or task unit (SPARK + -- RM 6.1.4(12)). if Appears_In (Inputs, Item_Id) and then not Appears_In (Outputs, Item_Id) @@ -2510,9 +2523,15 @@ package body Sem_Prag is ("global item & cannot have mode In_Out or Output", Item, Item_Id); - SPARK_Msg_NE - (Fix_Msg (Subp_Id, "\item already appears as input of " - & "subprogram &"), Item, Context); + if Is_Subprogram (Context) then + SPARK_Msg_NE + (Fix_Msg (Subp_Id, "\item already appears as input " + & "of subprogram &"), Item, Context); + else + SPARK_Msg_NE + (Fix_Msg (Subp_Id, "\item already appears as input " + & "of task &"), Item, Context); + end if; -- Stop the traversal once an error has been detected @@ -3200,20 +3219,21 @@ package body Sem_Prag is -- The item appears in the visible state space of some package. In -- general this scenario does not warrant Part_Of except when the - -- package is a private child unit and the encapsulating state is - -- declared in a parent unit or a public descendant of that parent - -- unit. + -- package is a nongeneric private child unit and the encapsulating + -- state is declared in a parent unit or a public descendant of that + -- parent unit. elsif Placement = Visible_State_Space then if Is_Child_Unit (Pack_Id) + and then not Is_Generic_Unit (Pack_Id) and then Is_Private_Descendant (Pack_Id) then -- A variable or state abstraction which is part of the visible - -- state of a private child unit or its public descendants must - -- have its Part_Of indicator specified. The Part_Of indicator - -- must denote a state declared by either the parent unit of - -- the private unit or by a public descendant of that parent - -- unit. + -- state of a nongeneric private child unit or its public + -- descendants must have its Part_Of indicator specified. The + -- Part_Of indicator must denote a state declared by either the + -- parent unit of the private unit or by a public descendant of + -- that parent unit. -- Find the nearest private ancestor (which can be the current -- unit itself). @@ -3250,8 +3270,9 @@ package body Sem_Prag is return; end if; - -- Indicator Part_Of is not needed when the related package is not - -- a private child unit or a public descendant thereof. + -- Indicator Part_Of is not needed when the related package is + -- not a nongeneric private child unit or a public descendant + -- thereof. else SPARK_Msg_N @@ -19961,8 +19982,18 @@ package body Sem_Prag is if not Comes_From_Source (Item_Id) then null; + -- Do not consider generic formals or their corresponding + -- actuals because they are not part of a visible state. + -- Note that both entities are marked as hidden. + + elsif Is_Hidden (Item_Id) then + null; + -- The Part_Of indicator turns an abstract state or an -- object into a constituent of the encapsulating state. + -- Note that constants are considered here even though + -- they may not depend on variable input. This check is + -- left to the SPARK prover. elsif Ekind_In (Item_Id, E_Abstract_State, E_Constant, @@ -28754,7 +28785,17 @@ package body Sem_Prag is if not Comes_From_Source (Item_Id) then null; - -- A visible state has been found + -- Do not consider generic formals or their corresponding actuals + -- because they are not part of a visible state. Note that both + -- entities are marked as hidden. + + elsif Is_Hidden (Item_Id) then + null; + + -- A visible state has been found. Note that constants are not + -- considered here because it is not possible to determine whether + -- they depend on variable input. This check is left to the SPARK + -- prover. elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then return True; @@ -28831,11 +28872,13 @@ package body Sem_Prag is -- In general an item declared in the visible state space of a package -- does not require a Part_Of indicator. The only exception is when the - -- related package is a private child unit in which case Part_Of must - -- denote a state in the parent unit or in one of its descendants. + -- related package is a nongeneric private child unit, in which case + -- Part_Of must denote a state in the parent unit or in one of its + -- descendants. elsif Placement = Visible_State_Space then if Is_Child_Unit (Pack_Id) + and then not Is_Generic_Unit (Pack_Id) and then Is_Private_Descendant (Pack_Id) then -- A package instantiation does not need a Part_Of indicator when @@ -28874,9 +28917,9 @@ package body Sem_Prag is -- A package instantiation does not need a Part_Of indicator when the -- related generic template has no visible state. - elsif Ekind (Pack_Id) = E_Package - and then Is_Generic_Instance (Pack_Id) - and then not Has_Visible_State (Pack_Id) + elsif Ekind (Item_Id) = E_Package + and then Is_Generic_Instance (Item_Id) + and then not Has_Visible_State (Item_Id) then null; @@ -29600,6 +29643,16 @@ package body Sem_Prag is if Nkind (Original_Node (Stmt)) = N_Expression_Function then return Stmt; + -- The subprogram declaration is an internally generated spec + -- for a stand-alone subrogram body declared inside a protected + -- body. + + elsif Present (Corresponding_Body (Stmt)) + and then Comes_From_Source (Corresponding_Body (Stmt)) + and then Is_Protected_Type (Current_Scope) + then + return Stmt; + -- The subprogram is actually an instance housed within an -- anonymous wrapper package. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index e569cc8..ddfa543 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -142,6 +142,12 @@ package body Sem_Res is -- a call, so such an operator is not treated as predefined by this -- predicate. + procedure Preanalyze_And_Resolve + (N : Node_Id; + T : Entity_Id; + With_Freezing : Boolean); + -- Subsidiary of public versions of Preanalyze_And_Resolve. + procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); -- If a default expression in entry call N depends on the discriminants -- of the task, it must be replaced with a reference to the discriminant @@ -1660,10 +1666,24 @@ package body Sem_Res is -- Preanalyze_And_Resolve -- ---------------------------- - procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is - Save_Full_Analysis : constant Boolean := Full_Analysis; - + procedure Preanalyze_And_Resolve + (N : Node_Id; + T : Entity_Id; + With_Freezing : Boolean) + is + Save_Full_Analysis : constant Boolean := Full_Analysis; + Save_Must_Not_Freeze : constant Boolean := Must_Not_Freeze (N); + Save_Preanalysis_Count : constant Nat := + Inside_Preanalysis_Without_Freezing; begin + pragma Assert (Nkind (N) in N_Subexpr); + + if not With_Freezing then + Set_Must_Not_Freeze (N); + Inside_Preanalysis_Without_Freezing := + Inside_Preanalysis_Without_Freezing + 1; + end if; + Full_Analysis := False; Expander_Mode_Save_And_Set (False); @@ -1690,6 +1710,24 @@ package body Sem_Res is Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; + Set_Must_Not_Freeze (N, Save_Must_Not_Freeze); + + if not With_Freezing then + Inside_Preanalysis_Without_Freezing := + Inside_Preanalysis_Without_Freezing - 1; + end if; + + pragma Assert + (Inside_Preanalysis_Without_Freezing = Save_Preanalysis_Count); + end Preanalyze_And_Resolve; + + ---------------------------- + -- Preanalyze_And_Resolve -- + ---------------------------- + + procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is + begin + Preanalyze_And_Resolve (N, T, With_Freezing => False); end Preanalyze_And_Resolve; -- Version without context type @@ -1708,6 +1746,18 @@ package body Sem_Res is Full_Analysis := Save_Full_Analysis; end Preanalyze_And_Resolve; + ------------------------------------------ + -- Preanalyze_With_Freezing_And_Resolve -- + ------------------------------------------ + + procedure Preanalyze_With_Freezing_And_Resolve + (N : Node_Id; + T : Entity_Id) + is + begin + Preanalyze_And_Resolve (N, T, With_Freezing => True); + end Preanalyze_With_Freezing_And_Resolve; + ---------------------------------- -- Replace_Actual_Discriminants -- ---------------------------------- @@ -3667,10 +3717,15 @@ package body Sem_Res is -- read IN, IN OUT -- write IN OUT, OUT - Build_Variable_Reference_Marker - (N => A, - Read => Ekind (F) /= E_Out_Parameter, - Write => Ekind (F) /= E_In_Parameter); + if Needs_Variable_Reference_Marker + (N => A, + Calls_OK => True) + then + Build_Variable_Reference_Marker + (N => A, + Read => Ekind (F) /= E_Out_Parameter, + Write => Ekind (F) /= E_In_Parameter); + end if; Orig_A := Entity (A); @@ -4971,9 +5026,10 @@ package body Sem_Res is if In_Instance_Body then Error_Msg_Warn := SPARK_Mode /= On; Error_Msg_N - ("type in allocator has deeper level than " - & "designated class-wide type<<", E); + ("type in allocator has deeper level than designated " + & "class-wide type<<", E); Error_Msg_N ("\Program_Error [<<", E); + Rewrite (N, Make_Raise_Program_Error (Sloc (N), Reason => PE_Accessibility_Check_Failed)); @@ -4984,16 +5040,22 @@ package body Sem_Res is -- type. A run-time check will be performed in the instance. elsif not Is_Generic_Type (Exp_Typ) then - Error_Msg_N ("type in allocator has deeper level than " - & "designated class-wide type", E); + Error_Msg_N + ("type in allocator has deeper level than designated " + & "class-wide type", E); end if; end if; end; end if; - -- Check for allocation from an empty storage pool + -- Check for allocation from an empty storage pool. But do not complain + -- if it's a return statement for a build-in-place function, because the + -- allocator is there just in case the caller uses an allocator. If the + -- caller does use an allocator, it will be caught at the call site. - if No_Pool_Assigned (Typ) then + if No_Pool_Assigned (Typ) + and then not Alloc_For_BIP_Return (N) + then Error_Msg_N ("allocation from empty storage pool!", N); -- If the context is an unchecked conversion, as may happen within an @@ -5369,7 +5431,7 @@ package body Sem_Res is -- A universal real conditional expression can appear in a fixed-type -- context and must be resolved with that context to facilitate the - -- code generation to the backend. + -- code generation in the back end. elsif Nkind_In (N, N_Case_Expression, N_If_Expression) and then Etype (N) = Universal_Real @@ -6371,7 +6433,7 @@ package body Sem_Res is null; elsif Expander_Active - and then Ekind (Nam) = E_Function + and then Ekind_In (Nam, E_Function, E_Subprogram_Type) and then Requires_Transient_Scope (Etype (Nam)) then Establish_Transient_Scope (N, Manage_Sec_Stack => True); @@ -6680,22 +6742,43 @@ package body Sem_Res is elsif Full_Analysis then - -- Do not inline calls inside expression functions, as this + -- Do not inline calls inside expression functions or functions + -- generated by the front end for subtype predicates, as this -- would prevent interpreting them as logical formulas in -- GNATprove. Only issue a message when the body has been seen, -- otherwise this leads to spurious messages on callees that -- are themselves expression functions. if Present (Current_Subprogram) - and then Is_Expression_Function_Or_Completion - (Current_Subprogram) + and then + (Is_Expression_Function_Or_Completion (Current_Subprogram) + or else Is_Predicate_Function (Current_Subprogram) + or else Is_Invariant_Procedure (Current_Subprogram) + or else Is_DIC_Procedure (Current_Subprogram)) then if Present (Body_Id) and then Present (Body_To_Inline (Nam_Decl)) then - Cannot_Inline - ("cannot inline & (inside expression function)?", - N, Nam_UA); + if Is_Predicate_Function (Current_Subprogram) then + Cannot_Inline + ("cannot inline & (inside predicate)?", + N, Nam_UA); + + elsif Is_Invariant_Procedure (Current_Subprogram) then + Cannot_Inline + ("cannot inline & (inside invariant)?", + N, Nam_UA); + + elsif Is_DIC_Procedure (Current_Subprogram) then + Cannot_Inline + ("cannot inline & (inside Default_Initial_Condition)?", + N, Nam_UA); + + else + Cannot_Inline + ("cannot inline & (inside expression function)?", + N, Nam_UA); + end if; end if; -- With the one-pass inlining technique, a call cannot be @@ -11849,7 +11932,7 @@ package body Sem_Res is Analyze_And_Resolve (String_Literal_Low_Bound (Subtype_Id)); -- Build bona fide subtype for the string, and wrap it in an - -- unchecked conversion, because the backend expects the + -- unchecked conversion, because the back end expects the -- String_Literal_Subtype to have a static lower bound. Index_Subtype := @@ -11859,7 +11942,7 @@ package body Sem_Res is Set_Parent (Drange, N); Analyze_And_Resolve (Drange, Index_Type); - -- In the context, the Index_Type may already have a constraint, + -- In this context, the Index_Type may already have a constraint, -- so use common base type on string subtype. The base type may -- be used when generating attributes of the string, for example -- in the context of a slice assignment. diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads index 58c8b5e..aeb758d 100644 --- a/gcc/ada/sem_res.ads +++ b/gcc/ada/sem_res.ads @@ -93,6 +93,9 @@ package Sem_Res is procedure Preanalyze_And_Resolve (N : Node_Id); -- Same, but use type of node because context does not impose a single type + procedure Preanalyze_With_Freezing_And_Resolve (N : Node_Id; T : Entity_Id); + -- Same, but perform freezing of static expressions of N or its children. + procedure Resolve (N : Node_Id; Typ : Entity_Id); procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id); -- Top-level type-checking procedure, called in a complete context. The diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 8fbad1d..bfa2b4f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3228,6 +3228,13 @@ package body Sem_Util is begin pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); + -- Nothing to do for internally-generated abstract states and variables + -- because they do not represent the hidden state of the source unit. + + if not Comes_From_Source (Id) then + return; + end if; + -- Find the proper context where the object or state appears Scop := Scope (Id); @@ -5986,12 +5993,6 @@ package body Sem_Util is ------------------------- function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is - Obj1 : Node_Id := A1; - Obj2 : Node_Id := A2; - - function Has_Prefix (N : Node_Id) return Boolean; - -- Return True if N has attribute Prefix - function Is_Renaming (N : Node_Id) return Boolean; -- Return true if N names a renaming entity @@ -6001,31 +6002,14 @@ package body Sem_Util is -- renamed object_name contains references to variables or calls on -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) - ---------------- - -- Has_Prefix -- - ---------------- - - function Has_Prefix (N : Node_Id) return Boolean is - begin - return - Nkind_In (N, - N_Attribute_Reference, - N_Expanded_Name, - N_Explicit_Dereference, - N_Indexed_Component, - N_Reference, - N_Selected_Component, - N_Slice); - end Has_Prefix; - ----------------- -- Is_Renaming -- ----------------- function Is_Renaming (N : Node_Id) return Boolean is begin - return Is_Entity_Name (N) - and then Present (Renamed_Entity (Entity (N))); + return + Is_Entity_Name (N) and then Present (Renamed_Entity (Entity (N))); end Is_Renaming; ----------------------- @@ -6033,10 +6017,13 @@ package body Sem_Util is ----------------------- function Is_Valid_Renaming (N : Node_Id) return Boolean is - function Check_Renaming (N : Node_Id) return Boolean; -- Recursive function used to traverse all the prefixes of N + -------------------- + -- Check_Renaming -- + -------------------- + function Check_Renaming (N : Node_Id) return Boolean is begin if Is_Renaming (N) @@ -6096,6 +6083,11 @@ package body Sem_Util is return Check_Renaming (N); end Is_Valid_Renaming; + -- Local variables + + Obj1 : Node_Id := A1; + Obj2 : Node_Id := A2; + -- Start of processing for Denotes_Same_Object begin @@ -6902,42 +6894,60 @@ package body Sem_Util is -------------------------- function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is - Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E); + Dyn_Scop : constant Entity_Id := Enclosing_Dynamic_Scope (E); begin - if Dynamic_Scope = Standard_Standard then + if Dyn_Scop = Standard_Standard then return Empty; - elsif Dynamic_Scope = Empty then + elsif Dyn_Scop = Empty then return Empty; - elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then - return Corresponding_Spec (Parent (Parent (Dynamic_Scope))); + elsif Ekind (Dyn_Scop) = E_Subprogram_Body then + return Corresponding_Spec (Parent (Parent (Dyn_Scop))); - elsif Ekind (Dynamic_Scope) = E_Block - or else Ekind (Dynamic_Scope) = E_Return_Statement - then - return Enclosing_Subprogram (Dynamic_Scope); + elsif Ekind_In (Dyn_Scop, E_Block, E_Return_Statement) then + return Enclosing_Subprogram (Dyn_Scop); - elsif Ekind (Dynamic_Scope) = E_Task_Type then - return Get_Task_Body_Procedure (Dynamic_Scope); + elsif Ekind (Dyn_Scop) = E_Entry then - elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type - and then Present (Full_View (Dynamic_Scope)) - and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type + -- For a task entry, return the enclosing subprogram of the + -- task itself. + + if Ekind (Scope (Dyn_Scop)) = E_Task_Type then + return Enclosing_Subprogram (Dyn_Scop); + + -- A protected entry is rewritten as a protected procedure which is + -- the desired enclosing subprogram. This is relevant when unnesting + -- a procedure local to an entry body. + + else + return Protected_Body_Subprogram (Dyn_Scop); + end if; + + elsif Ekind (Dyn_Scop) = E_Task_Type then + return Get_Task_Body_Procedure (Dyn_Scop); + + -- The scope may appear as a private type or as a private extension + -- whose completion is a task or protected type. + + elsif Ekind_In (Dyn_Scop, E_Limited_Private_Type, + E_Record_Type_With_Private) + and then Present (Full_View (Dyn_Scop)) + and then Ekind_In (Full_View (Dyn_Scop), E_Task_Type, E_Protected_Type) then - return Get_Task_Body_Procedure (Full_View (Dynamic_Scope)); + return Get_Task_Body_Procedure (Full_View (Dyn_Scop)); -- No body is generated if the protected operation is eliminated - elsif Convention (Dynamic_Scope) = Convention_Protected - and then not Is_Eliminated (Dynamic_Scope) - and then Present (Protected_Body_Subprogram (Dynamic_Scope)) + elsif Convention (Dyn_Scop) = Convention_Protected + and then not Is_Eliminated (Dyn_Scop) + and then Present (Protected_Body_Subprogram (Dyn_Scop)) then - return Protected_Body_Subprogram (Dynamic_Scope); + return Protected_Body_Subprogram (Dyn_Scop); else - return Dynamic_Scope; + return Dyn_Scop; end if; end Enclosing_Subprogram; @@ -7450,7 +7460,17 @@ package body Sem_Util is -- Ren : ... renames Obj; if Is_Entity_Name (Ren) then - Id := Entity (Ren); + + -- Do not follow a renaming that goes through a generic formal, + -- because these entities are hidden and must not be referenced + -- from outside the generic. + + if Is_Hidden (Entity (Ren)) then + exit; + + else + Id := Entity (Ren); + end if; -- The reference renames a function result. Check the original -- node in case expansion relocates the function call. @@ -8334,13 +8354,18 @@ package body Sem_Util is -- Search for the equality primitive; return Empty if the primitive is -- not found. + ------------------ + -- Find_Eq_Prim -- + ------------------ + function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id is - Prim_E : Elmt_Id := First_Elmt (Prims_List); - Prim : Entity_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; begin - while Present (Prim_E) loop - Prim := Node (Prim_E); + Prim_Elmt := First_Elmt (Prims_List); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); -- Locate primitive equality with the right signature @@ -8352,7 +8377,7 @@ package body Sem_Util is return Prim; end if; - Next_Elmt (Prim_E); + Next_Elmt (Prim_Elmt); end loop; return Empty; @@ -8360,8 +8385,8 @@ package body Sem_Util is -- Local Variables - Full_Type : Entity_Id; Eq_Prim : Entity_Id; + Full_Type : Entity_Id; -- Start of processing for Find_Primitive_Eq @@ -8797,19 +8822,19 @@ package body Sem_Util is Assoc := First (Governed_By); Find_Constraint : loop Discrim := First (Choices (Assoc)); - exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim) - or else (Present (Corresponding_Discriminant (Entity (Discrim))) - and then - Chars (Corresponding_Discriminant (Entity (Discrim))) = - Chars (Discrim_Name)) - or else Chars (Original_Record_Component (Entity (Discrim))) - = Chars (Discrim_Name); + exit Find_Constraint when + Chars (Discrim_Name) = Chars (Discrim) + or else + (Present (Corresponding_Discriminant (Entity (Discrim))) + and then Chars (Corresponding_Discriminant + (Entity (Discrim))) = Chars (Discrim_Name)) + or else + Chars (Original_Record_Component (Entity (Discrim))) = + Chars (Discrim_Name); if No (Next (Assoc)) then - if not Is_Constrained (Typ) - and then Is_Derived_Type (Typ) - and then Present (Stored_Constraint (Typ)) - then + if not Is_Constrained (Typ) and then Is_Derived_Type (Typ) then + -- If the type is a tagged type with inherited discriminants, -- use the stored constraint on the parent in order to find -- the values of discriminants that are otherwise hidden by an @@ -8822,43 +8847,60 @@ package body Sem_Util is -- of them. We recover the constraint on the others from the -- Stored_Constraint as well. + -- An inherited discriminant may have been constrained in a + -- later ancestor (not the immediate parent) so we must examine + -- the stored constraint of all of them to locate the inherited + -- value. + declare - D : Entity_Id; C : Elmt_Id; + D : Entity_Id; + T : Entity_Id := Typ; begin - D := First_Discriminant (Etype (Typ)); - C := First_Elmt (Stored_Constraint (Typ)); - while Present (D) and then Present (C) loop - if Chars (Discrim_Name) = Chars (D) then - if Is_Entity_Name (Node (C)) - and then Entity (Node (C)) = Entity (Discrim) - then - -- D is renamed by Discrim, whose value is given in - -- Assoc. + while Is_Derived_Type (T) loop + if Present (Stored_Constraint (T)) then + D := First_Discriminant (Etype (T)); + C := First_Elmt (Stored_Constraint (T)); + while Present (D) and then Present (C) loop + if Chars (Discrim_Name) = Chars (D) then + if Is_Entity_Name (Node (C)) + and then Entity (Node (C)) = Entity (Discrim) + then + -- D is renamed by Discrim, whose value is + -- given in Assoc. - null; + null; - else - Assoc := - Make_Component_Association (Sloc (Typ), - New_List - (New_Occurrence_Of (D, Sloc (Typ))), - Duplicate_Subexpr_No_Checks (Node (C))); - end if; - exit Find_Constraint; + else + Assoc := + Make_Component_Association (Sloc (Typ), + New_List + (New_Occurrence_Of (D, Sloc (Typ))), + Duplicate_Subexpr_No_Checks (Node (C))); + end if; + + exit Find_Constraint; + end if; + + Next_Discriminant (D); + Next_Elmt (C); + end loop; end if; - Next_Discriminant (D); - Next_Elmt (C); + -- Discriminant may be inherited from ancestor + + T := Etype (T); end loop; end; end if; end if; if No (Next (Assoc)) then - Error_Msg_NE (" missing value for discriminant&", - First (Governed_By), Discrim_Name); + Error_Msg_NE + (" missing value for discriminant&", + First (Governed_By), Discrim_Name); + Report_Errors := True; return; end if; @@ -11543,6 +11585,22 @@ package body Sem_Util is return Has_PE; end Has_Preelaborable_Initialization; + ---------------- + -- Has_Prefix -- + ---------------- + + function Has_Prefix (N : Node_Id) return Boolean is + begin + return + Nkind_In (N, N_Attribute_Reference, + N_Expanded_Name, + N_Explicit_Dereference, + N_Indexed_Component, + N_Reference, + N_Selected_Component, + N_Slice); + end Has_Prefix; + --------------------------- -- Has_Private_Component -- --------------------------- @@ -13362,12 +13420,7 @@ package body Sem_Util is function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is begin - return Nkind_In (N, N_Entry_Body, - N_Package_Body, - N_Package_Declaration, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body); + return Is_Body (N) or else Nkind (N) = N_Package_Declaration; end Is_Body_Or_Package_Declaration; ----------------------- @@ -16448,7 +16501,9 @@ package body Sem_Util is while Present (Par) and then Nkind (Par) /= N_Pragma_Argument_Association loop - if Nkind (Original_Node (Par)) = N_And_Then then + if Is_Rewrite_Substitution (Par) + and then Nkind (Original_Node (Par)) = N_And_Then + then return True; end if; @@ -18467,6 +18522,7 @@ package body Sem_Util is begin if Nkind (N) = N_Allocator then if Is_Dynamic then + Set_Is_Static_Coextension (N, False); Set_Is_Dynamic_Coextension (N); -- If the allocator expression is potentially dynamic, it may @@ -18477,8 +18533,10 @@ package body Sem_Util is elsif Nkind (Expression (N)) = N_Qualified_Expression and then Nkind (Expression (Expression (N))) = N_Op_Concat then + Set_Is_Static_Coextension (N, False); Set_Is_Dynamic_Coextension (N); else + Set_Is_Dynamic_Coextension (N, False); Set_Is_Static_Coextension (N); end if; end if; @@ -19247,6 +19305,144 @@ package body Sem_Util is end if; end Needs_Simple_Initialization; + ------------------------------------- + -- Needs_Variable_Reference_Marker -- + ------------------------------------- + + function Needs_Variable_Reference_Marker + (N : Node_Id; + Calls_OK : Boolean) return Boolean + is + function Within_Suitable_Context (Ref : Node_Id) return Boolean; + -- Deteremine whether variable reference Ref appears within a suitable + -- context that allows the creation of a marker. + + ----------------------------- + -- Within_Suitable_Context -- + ----------------------------- + + function Within_Suitable_Context (Ref : Node_Id) return Boolean is + Par : Node_Id; + + begin + Par := Ref; + while Present (Par) loop + + -- The context is not suitable when the reference appears within + -- the formal part of an instantiation which acts as compilation + -- unit because there is no proper list for the insertion of the + -- marker. + + if Nkind (Par) = N_Generic_Association + and then Nkind (Parent (Par)) in N_Generic_Instantiation + and then Nkind (Parent (Parent (Par))) = N_Compilation_Unit + then + return False; + + -- The context is not suitable when the reference appears within + -- a pragma. If the pragma has run-time semantics, the reference + -- will be reconsidered once the pragma is expanded. + + elsif Nkind (Par) = N_Pragma then + return False; + + -- The context is not suitable when the reference appears within a + -- subprogram call, and the caller requests this behavior. + + elsif not Calls_OK + and then Nkind_In (Par, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) + then + return False; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + + return True; + end Within_Suitable_Context; + + -- Local variables + + Prag : Node_Id; + Var_Id : Entity_Id; + + -- Start of processing for Needs_Variable_Reference_Marker + + begin + -- No marker needs to be created when switch -gnatH (legacy elaboration + -- checking mode enabled) is in effect because the legacy ABE mechanism + -- does not use markers. + + if Legacy_Elaboration_Checks then + return False; + + -- No marker needs to be created for ASIS because ABE diagnostics and + -- checks are not performed in this mode. + + elsif ASIS_Mode then + return False; + + -- No marker needs to be created when the reference is preanalyzed + -- because the marker will be inserted in the wrong place. + + elsif Preanalysis_Active then + return False; + + -- Only references warrant a marker + + elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then + return False; + + -- Only source references warrant a marker + + elsif not Comes_From_Source (N) then + return False; + + -- No marker needs to be created when the reference is erroneous, left + -- in a bad state, or does not denote a variable. + + elsif not (Present (Entity (N)) + and then Ekind (Entity (N)) = E_Variable + and then Entity (N) /= Any_Id) + then + return False; + end if; + + Var_Id := Entity (N); + Prag := SPARK_Pragma (Var_Id); + + -- Both the variable and reference must appear in SPARK_Mode On regions + -- because this elaboration scenario falls under the SPARK rules. + + if not (Comes_From_Source (Var_Id) + and then Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On + and then Is_SPARK_Mode_On_Node (N)) + then + return False; + + -- No marker needs to be created when the reference does not appear + -- within a suitable context (see body for details). + + -- Performance note: parent traversal + + elsif not Within_Suitable_Context (N) then + return False; + end if; + + -- At this point it is known that the variable reference will play a + -- role in ABE diagnostics and requires a marker. + + return True; + end Needs_Variable_Reference_Marker; + ------------------------ -- New_Copy_List_Tree -- ------------------------ @@ -19349,10 +19545,11 @@ package body Sem_Util is ------------------- function New_Copy_Tree - (Source : Node_Id; - Map : Elist_Id := No_Elist; - New_Sloc : Source_Ptr := No_Location; - New_Scope : Entity_Id := Empty) return Node_Id + (Source : Node_Id; + Map : Elist_Id := No_Elist; + New_Sloc : Source_Ptr := No_Location; + New_Scope : Entity_Id := Empty; + Scopes_In_EWA_OK : Boolean := False) return Node_Id is -- This routine performs low-level tree manipulations and needs access -- to the internals of the tree. @@ -20274,34 +20471,44 @@ package body Sem_Util is pragma Assert (Nkind (Id) in N_Entity); pragma Assert (not Is_Itype (Id)); - -- Nothing to do if the entity is not defined in the Actions list of - -- an N_Expression_With_Actions node. + -- Nothing to do when the entity is not defined in the Actions list + -- of an N_Expression_With_Actions node. if EWA_Level = 0 then return; - -- Nothing to do if the entity is defined within a scoping construct - -- of an N_Expression_With_Actions node. + -- Nothing to do when the entity is defined in a scoping construct + -- within an N_Expression_With_Actions node, unless the caller has + -- requested their replication. + + -- ??? should this restriction be eliminated? - elsif EWA_Inner_Scope_Level > 0 then + elsif EWA_Inner_Scope_Level > 0 and then not Scopes_In_EWA_OK then return; - -- Nothing to do if the entity is not an object or a type. Relaxing + -- Nothing to do when the entity does not denote a construct that + -- may appear within an N_Expression_With_Actions node. Relaxing -- this restriction leads to a performance penalty. - elsif not Ekind_In (Id, E_Constant, E_Variable) + -- ??? this list is flaky, and may hide dormant bugs + + elsif not Ekind_In (Id, E_Block, + E_Constant, + E_Label, + E_Procedure, + E_Variable) and then not Is_Type (Id) then return; - -- Nothing to do if the entity was already visited + -- Nothing to do when the entity was already visited elsif NCT_Tables_In_Use and then Present (NCT_New_Entities.Get (Id)) then return; - -- Nothing to do if the declaration node of the entity is not within + -- Nothing to do when the declaration node of the entity is not in -- the subtree being replicated. elsif not In_Subtree @@ -20840,7 +21047,8 @@ package body Sem_Util is ----------------- function Next_Actual (Actual_Id : Node_Id) return Node_Id is - N : Node_Id; + Par : constant Node_Id := Parent (Actual_Id); + N : Node_Id; begin -- If we are pointing at a positional parameter, it is a member of a @@ -20860,11 +21068,22 @@ package body Sem_Util is -- In case of a build-in-place call, the call will no longer be a -- call; it will have been rewritten. - if Nkind_In (Parent (Actual_Id), N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind_In (Par, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) then - return First_Named_Actual (Parent (Actual_Id)); + return First_Named_Actual (Par); + + -- In case of a call rewritten in GNATprove mode while "inlining + -- for proof" go to the original call. + + elsif Nkind (Par) = N_Null_Statement then + pragma Assert + (GNATprove_Mode + and then + Nkind (Original_Node (Par)) in N_Subprogram_Call); + + return First_Named_Actual (Original_Node (Par)); else return Empty; end if; @@ -23045,19 +23264,19 @@ package body Sem_Util is if Has_Inheritable_Invariants (From_Typ) and then not Has_Inheritable_Invariants (Typ) then - Set_Has_Inheritable_Invariants (Typ, True); + Set_Has_Inheritable_Invariants (Typ); end if; if Has_Inherited_Invariants (From_Typ) and then not Has_Inherited_Invariants (Typ) then - Set_Has_Inherited_Invariants (Typ, True); + Set_Has_Inherited_Invariants (Typ); end if; if Has_Own_Invariants (From_Typ) and then not Has_Own_Invariants (Typ) then - Set_Has_Own_Invariants (Typ, True); + Set_Has_Own_Invariants (Typ); end if; if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then @@ -23805,6 +24024,21 @@ package body Sem_Util is if Curr = Outer then return True; + + -- A selective accept body appears within a task type, but the + -- enclosing subprogram is the procedure of the task body. + + elsif Ekind (Curr) = E_Task_Type + and then Outer = Task_Body_Procedure (Curr) + then + return True; + + -- Ditto for the body of a protected operation + + elsif Is_Subprogram (Curr) + and then Outer = Protected_Body_Subprogram (Curr) + then + return True; end if; end loop; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index a2eca15..aec3644 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -126,8 +126,8 @@ package Sem_Util is Loc : Source_Ptr := No_Location; Rep : Boolean := True; Warn : Boolean := False); - -- N is a subexpression which will raise constraint error when evaluated - -- at runtime. Msg is a message that explains the reason for raising the + -- N is a subexpression that will raise Constraint_Error when evaluated + -- at run time. Msg is a message that explains the reason for raising the -- exception. The last character is ? if the message is always a warning, -- even in Ada 95, and is not a ? if the message represents an illegality -- (because of violation of static expression rules) in Ada 95 (but not @@ -585,7 +585,7 @@ package Sem_Util is function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean; -- Detect suspicious overlapping between actuals in a call, when both are - -- writable (RM 2012 6.4.1(6.4/3)) + -- writable (RM 2012 6.4.1(6.4/3)). function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean; -- Functions to detect suspicious overlapping between actuals in a call, @@ -614,19 +614,19 @@ package Sem_Util is -- Emit an error if iterated component association N is actually an illegal -- quantified expression lacking a quantifier. - function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id; - -- Expr should be an expression of an access type. Builds an integer - -- literal except in cases involving anonymous access types where - -- accessibility levels are tracked at runtime (access parameters and Ada - -- 2012 stand-alone objects). - function Discriminated_Size (Comp : Entity_Id) return Boolean; -- If a component size is not static then a warning will be emitted -- in Ravenscar or other restricted contexts. When a component is non- -- static because of a discriminant constraint we can specialize the -- warning by mentioning discriminants explicitly. This was created for -- private components of protected objects, but is generally useful when - -- retriction (No_Implicit_Heap_Allocation) is active. + -- restriction No_Implicit_Heap_Allocation is active. + + function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id; + -- Expr should be an expression of an access type. Builds an integer + -- literal except in cases involving anonymous access types, where + -- accessibility levels are tracked at run time (access parameters and + -- Ada 2012 stand-alone objects). function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id; -- Same as Einfo.Extra_Accessibility except thtat object renames @@ -705,7 +705,8 @@ package Sem_Util is function Entity_Of (N : Node_Id) return Entity_Id; -- Obtain the entity of arbitrary node N. If N is a renaming, return the -- entity of the earliest renamed source abstract state or whole object. - -- If no suitable entity is available, return Empty. + -- If no suitable entity is available, return Empty. This routine carries + -- out actions that are tied to SPARK semantics. procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id); -- This procedure is called after issuing a message complaining about an @@ -872,7 +873,7 @@ package Sem_Util is Placement : out State_Space_Kind; Pack_Id : out Entity_Id); -- Determine the state space placement of an item. Item_Id denotes the - -- entity of an abstract state, object or package instantiation. Placement + -- entity of an abstract state, object, or package instantiation. Placement -- captures the precise placement of the item in the enclosing state space. -- If the state space is that of a package, Pack_Id denotes its entity, -- otherwise Pack_Id is Empty. @@ -1313,6 +1314,9 @@ package Sem_Util is -- Return True iff type E has preelaborable initialization as defined in -- Ada 2005 (see AI-161 for details of the definition of this attribute). + function Has_Prefix (N : Node_Id) return Boolean; + -- Return True if N has attribute Prefix + function Has_Private_Component (Type_Id : Entity_Id) return Boolean; -- Check if a type has a (sub)component of a private type that has not -- yet received a full declaration. @@ -2022,7 +2026,7 @@ package Sem_Util is function Is_Transfer (N : Node_Id) return Boolean; -- Returns True if the node N is a statement which is known to cause an - -- unconditional transfer of control at runtime, i.e. the following + -- unconditional transfer of control at run time, i.e. the following -- statement definitely will not be executed. function Is_True (U : Uint) return Boolean; @@ -2224,16 +2228,24 @@ package Sem_Util is -- set to False, but if Consider_IS is set to True, then the cases above -- mentioning Normalize_Scalars also apply for Initialize_Scalars mode. + function Needs_Variable_Reference_Marker + (N : Node_Id; + Calls_OK : Boolean) return Boolean; + -- Determine whether arbitrary node N denotes a reference to a variable + -- which is suitable for SPARK elaboration checks. Flag Calls_OK should + -- be set when the reference is allowed to appear within calls. + function New_Copy_List_Tree (List : List_Id) return List_Id; -- Copy recursively an analyzed list of nodes. Uses New_Copy_Tree defined -- below. As for New_Copy_Tree, it is illegal to attempt to copy extended -- nodes (entities) either directly or indirectly using this function. function New_Copy_Tree - (Source : Node_Id; - Map : Elist_Id := No_Elist; - New_Sloc : Source_Ptr := No_Location; - New_Scope : Entity_Id := Empty) return Node_Id; + (Source : Node_Id; + Map : Elist_Id := No_Elist; + New_Sloc : Source_Ptr := No_Location; + New_Scope : Entity_Id := Empty; + Scopes_In_EWA_OK : Boolean := False) return Node_Id; -- Perform a deep copy of the subtree rooted at Source. Entities, itypes, -- and nodes are handled separately as follows: -- @@ -2303,6 +2315,10 @@ package Sem_Util is -- -- Parameter New_Scope may be used to specify a new scope for all copied -- entities and itypes. + -- + -- Parameter Scopes_In_EWA_OK may be used to force the replication of both + -- scoping entities and non-scoping entities found within expression with + -- actions nodes. function New_External_Entity (Kind : Entity_Kind; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 7c3254e..ee0ec6d 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -3630,9 +3630,8 @@ package body Sem_Warn is Form1 : Entity_Id; Form2 : Entity_Id; Warn_Only : Boolean; - -- GNAT warns on overlapping in-out parameters even when there are no - -- two in-out parameters of an elementary type, as stated in - -- RM 6.5.1 (17/2). + -- GNAT warns on overlapping in-out parameters of any type, not just for + -- elementary in-out parameters (as specified in RM 6.4.1 (15/3-17/3)). -- Start of processing for Warn_On_Overlapping_Actuals diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb index 5dd65fb..e37906d 100644 --- a/gcc/ada/sfn_scan.adb +++ b/gcc/ada/sfn_scan.adb @@ -106,6 +106,7 @@ package body SFN_Scan is -- ('a' .. 'z'). procedure Error (Err : String); + pragma No_Return (Error); -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC -- with a message of the form gnat.adc:line:col: xxx, where xxx is -- the string Err passed as a parameter. diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index acb3215..e6ff0e7 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -3522,14 +3522,6 @@ package body Sinfo is return Flag13 (N); end Was_Originally_Stub; - function Withed_Body - (N : Node_Id) return Node_Id is - begin - pragma Assert (False - or else NT (N).Nkind = N_With_Clause); - return Node1 (N); - end Withed_Body; - -------------------------- -- Field Set Procedures -- -------------------------- @@ -5350,6 +5342,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Allocator); + pragma Assert (not Val + or else not Is_Static_Coextension (N)); Set_Flag18 (N, Val); end Set_Is_Dynamic_Coextension; @@ -5613,6 +5607,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Allocator); + pragma Assert (not Val + or else not Is_Dynamic_Coextension (N)); Set_Flag14 (N, Val); end Set_Is_Static_Coextension; @@ -6986,14 +6982,6 @@ package body Sinfo is Set_Flag13 (N, Val); end Set_Was_Originally_Stub; - procedure Set_Withed_Body - (N : Node_Id; Val : Node_Id) is - begin - pragma Assert (False - or else NT (N).Nkind = N_With_Clause); - Set_Node1 (N, Val); - end Set_Withed_Body; - ------------------------- -- Iterator Procedures -- ------------------------- diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 6aaeff8..ae29661 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1738,7 +1738,8 @@ package Sinfo is -- Present in allocator nodes, to indicate that this is an allocator -- for an access discriminant of a dynamically allocated object. The -- coextension must be deallocated and finalized at the same time as - -- the enclosing object. + -- the enclosing object. The partner flag Is_Static_Coextension must + -- be cleared before setting this flag to True. -- Is_Effective_Use_Clause (Flag1-Sem) -- Present in both N_Use_Type_Clause and N_Use_Package_Clause to indicate @@ -1949,7 +1950,9 @@ package Sinfo is -- Is_Static_Coextension (Flag14-Sem) -- Present in N_Allocator nodes. Set if the allocator is a coextension - -- of an object allocated on the stack rather than the heap. + -- of an object allocated on the stack rather than the heap. The partner + -- flag Is_Dynamic_Coextension must be cleared before setting this flag + -- to True. -- Is_Static_Expression (Flag6-Sem) -- Indicates that an expression is a static expression according to the @@ -2371,7 +2374,7 @@ package Sinfo is -- Split_PPC (Flag17) -- When a Pre or Post aspect specification is processed, it is broken - -- into AND THEN sections. The left most section has Split_PPC set to + -- into AND THEN sections. The leftmost section has Split_PPC set to -- False, indicating that it is the original specification (e.g. for -- posting errors). For other sections, Split_PPC is set to True. -- This flag is set in both the N_Aspect_Specification node itself, @@ -2501,12 +2504,6 @@ package Sinfo is -- Original_Node here because of the case of nested instantiations where -- the substituted node can be copied. - -- Withed_Body (Node1-Sem) - -- Present in N_With_Clause nodes. Set if the unit in whose context - -- the with_clause appears instantiates a generic contained in the - -- library unit of the with_clause and as a result loads its body. - -- Used for a more precise unit traversal for CodePeer. - -------------------------------------------------- -- Note on Use of End_Label and End_Span Fields -- -------------------------------------------------- @@ -6740,7 +6737,6 @@ package Sinfo is -- N_With_Clause -- Sloc points to first token of library unit name - -- Withed_Body (Node1-Sem) -- Name (Node2) -- Private_Present (Flag15) set if with_clause has private keyword -- Limited_Present (Flag17) set if LIMITED is present @@ -10304,9 +10300,6 @@ package Sinfo is function Was_Originally_Stub (N : Node_Id) return Boolean; -- Flag13 - function Withed_Body - (N : Node_Id) return Node_Id; -- Node1 - -- End functions (note used by xsinfo utility program to end processing) ---------------------------- @@ -11405,9 +11398,6 @@ package Sinfo is procedure Set_Was_Originally_Stub (N : Node_Id; Val : Boolean := True); -- Flag13 - procedure Set_Withed_Body - (N : Node_Id; Val : Node_Id); -- Node1 - ------------------------- -- Iterator Procedures -- ------------------------- @@ -13610,7 +13600,6 @@ package Sinfo is pragma Inline (Was_Attribute_Reference); pragma Inline (Was_Expression_Function); pragma Inline (Was_Originally_Stub); - pragma Inline (Withed_Body); pragma Inline (Set_Abort_Present); pragma Inline (Set_Abortable_Part); @@ -13972,6 +13961,5 @@ package Sinfo is pragma Inline (Set_Was_Attribute_Reference); pragma Inline (Set_Was_Expression_Function); pragma Inline (Set_Was_Originally_Stub); - pragma Inline (Set_Withed_Body); end Sinfo; diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index cdf14cf..754e8d8 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -461,6 +461,7 @@ begin Write_Line (" I turn off checking for in params"); Write_Line (" m turn on checking for in out params"); Write_Line (" M turn off checking for in out params"); + Write_Line (" n turn off all validity checks (including RM)"); Write_Line (" o turn on checking for operators/attributes"); Write_Line (" O turn off checking for operators/attributes"); Write_Line (" p turn on checking for parameters"); @@ -471,7 +472,6 @@ begin Write_Line (" S turn off checking for subscripts"); Write_Line (" t turn on checking for tests"); Write_Line (" T turn off checking for tests"); - Write_Line (" n turn off all validity checks (including RM)"); -- Lines for -gnatw switch diff --git a/gcc/ada/vxaddr2line.adb b/gcc/ada/vxaddr2line.adb index 3370c82..e893aa4 100644 --- a/gcc/ada/vxaddr2line.adb +++ b/gcc/ada/vxaddr2line.adb @@ -209,6 +209,7 @@ procedure VxAddr2Line is -- Prints the message and then terminates the program procedure Usage; + pragma No_Return (Usage); -- Displays the short help message and then terminates the program function Get_Reference_Offset return Unsigned_64; @@ -319,7 +320,7 @@ procedure VxAddr2Line is declare Match_String : constant String := Expect_Out_Match (Pd); Matches : Match_Array (0 .. 1); - Value : Unsigned_64; + Value : Unsigned_64 := 0; begin Match (Reference, Match_String, Matches); diff --git a/gcc/ada/xeinfo.adb b/gcc/ada/xeinfo.adb index edb871a..5131907 100644 --- a/gcc/ada/xeinfo.adb +++ b/gcc/ada/xeinfo.adb @@ -151,6 +151,7 @@ procedure XEinfo is Lastinlined : Boolean; procedure Badfunc; + pragma No_Return (Badfunc); -- Signal bad function in body function Getlin return VString; diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb index 48a25d1..ca4121f 100644 --- a/gcc/ada/xoscons.adb +++ b/gcc/ada/xoscons.adb @@ -166,7 +166,7 @@ procedure XOSCons is A2 : Long_Unsigned renames V2.Abs_Value; begin return (P1 and then not P2) - or else (P1 and then P2 and then A1 > A2) + or else (P1 and then A1 > A2) or else (not P1 and then not P2 and then A1 < A2); end ">"; diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb index 8df2686..1831d69 100644 --- a/gcc/ada/xr_tabls.adb +++ b/gcc/ada/xr_tabls.adb @@ -761,6 +761,9 @@ package body Xr_Tabls is With_Dir : Boolean := False; Strip : Natural := 0) return String is + pragma Annotate (CodePeer, Skip_Analysis); + -- ??? To disable false positives currently generated + Tmp : GNAT.OS_Lib.String_Access; function Internal_Strip (Full_Name : String) return String; diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index b656ac0..d211a28 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.adb @@ -75,7 +75,7 @@ package body Xref_Lib is procedure Open (Name : String; - File : out ALI_File; + File : in out ALI_File; Dependencies : Boolean := False); -- Open a new ALI file. If Dependencies is True, the insert every library -- file 'with'ed in the files database (used for gnatxref) @@ -688,7 +688,7 @@ package body Xref_Lib is procedure Open (Name : String; - File : out ALI_File; + File : in out ALI_File; Dependencies : Boolean := False) is Ali : String_Access renames File.Buffer; |