diff options
author | Ian Lance Taylor <ian@gcc.gnu.org> | 2019-12-13 22:10:44 +0000 |
---|---|---|
committer | Ian Lance Taylor <ian@gcc.gnu.org> | 2019-12-13 22:10:44 +0000 |
commit | 51426017f8fe0f18295ca467feba3fbb5aad3fa8 (patch) | |
tree | 2f686f2d4657aa570473986e7d0924794093c67b /gcc/ada | |
parent | 0cec14923830569b8727d461bcf64adaf965de83 (diff) | |
parent | c926fd82bbd336b317266d43b9fa67a83397b06b (diff) | |
download | gcc-51426017f8fe0f18295ca467feba3fbb5aad3fa8.zip gcc-51426017f8fe0f18295ca467feba3fbb5aad3fa8.tar.gz gcc-51426017f8fe0f18295ca467feba3fbb5aad3fa8.tar.bz2 |
Merge from trunk revision 279830.
From-SVN: r279387
Diffstat (limited to 'gcc/ada')
99 files changed, 2317 insertions, 885 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e0d4e65..1fea353 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,518 @@ +2019-12-13 Gary Dismukes <dismukes@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: Minor + rewording of one sentence. + * gnat_rm.texi: Regenerate. + +2019-12-13 Arnaud Charlet <charlet@adacore.com> + + * exp_unst.adb (Unnest_Subprogram): Account for trees produced + by Annex E constructs. + +2019-12-13 Ghjuvan Lacambre <lacambre@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: Update + Initialize_Scalars documentation. + * gnat_rm.texi: Regenerate. + +2019-12-13 Javier Miranda <miranda@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specification): Processing a + precondition, if the expression is of the form A and then B, do + not generate separate Pre/Post aspects for the separate clases + when we are processing a generic unit. Required to avoid + reporting spurious visibility errors on the instantiations. + +2019-12-13 Eric Botcazou <ebotcazou@adacore.com> + + * sem_res.adb (Resolve_Actuals): Give canonical error for + illegal case of atomic/volatile parameter also if the formal is + aliased. + +2019-12-13 Eric Botcazou <ebotcazou@adacore.com> + + * sem_util.ads (Is_Atomic_Object): Mention relevant RM clauses. + * sem_util.adb (Is_Atomic_Object): For an indexed component, + only look at the Has_Atomic_Components aspect of the prefix and + do not recurse on it; for a selected component, do not look at + the prefix. + (Is_Atomic_Or_VFA_Object): Minor tweak. + +2019-12-13 Arnaud Charlet <charlet@adacore.com> + + * libgnat/a-calfor.ads, libgnat/a-calfor.adb (Split_Duration): + New procedure. + (Split, Image): Use Split_Duration. Update Image spec. + +2019-12-13 Javier Miranda <miranda@adacore.com> + + * exp_unst.adb (Unnest_Subprogram): Generate an extra temporary + to facilitate the C backend processing dereferences. + +2019-12-13 Javier Miranda <miranda@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Propagate the + Linker_Section_Attribute to the ultimate alias of the subprogram + to facilitate the C backend processing this attribute. + +2019-12-13 Yannick Moy <moy@adacore.com> + + * sem_util.adb (Original_Aspect_Pragma_Name): Go through + Original_Node for pragma. + +2019-12-13 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb, exp_unst.adb: Minor fix typo in comment. + +2019-12-13 Steve Baird <baird@adacore.com> + + * sem_res.adb (Resolve, Valid_Conversion): Add Base_Type call + when testing whether a type is a general access type. + +2019-12-13 Javier Miranda <miranda@adacore.com> + + * exp_ch4.adb (Expand_N_Unchecked_Type_Conversion): Generate an + extra temporary for cases unsupported by the C backend. + +2019-12-13 Steve Baird <baird@adacore.com> + + * einfo.ads: Correct comment for Derived_Type_Link to reflect + that fact that this function is now used for more than just + generation of warnings. + * sem_ch3.adb (Build_Derived_Type): Do not call + Set_Derived_Type_Link if the derived type and the parent type + are in different compilation units. Such a derivation cannot be + a problematic "early" derivation (identifying these is what the + Derived_Type_Link attribute is used for) and we don't like + inter-unit references that go in the opposite direction of + semantic dependencies. + * sem_ch13.adb (Is_Type_Related_Rep_Item): A new function, + analogous to the existing function Is_Operational_Item. + (Rep_Item_Too_Late): Generate a hard error (with same text as + the warning that was previously being generated) if the + AI12-0109 legality rule is violated. + +2019-12-13 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: Minor tweak to + Volatile_Full_Access wording in GNAT RM. + * gnat_rm.texi: Regenerate. + +2019-12-13 Gary Dismukes <dismukes@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference, + Attribute_Address): Suppress generation of a call to + Base_Address in the case where the Address attribute is being + used to initialize a corresponding component of an activation + record. + (Is_Unnested_Component_Init): New function to determine whether + an attribute reference for Address is used to initialized a + component of an activation record object that corresponds to the + object denoted by the prefix of the attribute (an assignment + used in support of unnesting for back ends like LLVM). + +2019-12-13 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve): IF an entity reference is overloaded + because its type has an Implicit_Dereference aspect, we must + examine the discriminants of the type to determine whether an + explicit dereference must be inserted for use in code + generation. Previously this was done for other expressions but + not for entity references by themselves. This was sufficient to + handle uses of the aspect in container handling and iteration, + but not more generally. + +2019-12-13 Javier Miranda <miranda@adacore.com> + + * exp_disp.ads (Expand_Interface_Thunk): Adding one formal (the + interface type). + * exp_disp.adb (Expand_Interface_Thunk): Using the added formal + to ensure the correct profile of the thunk generated for + predefined primitives; in addition, the added formal is also + used to perform a check that ensures that the controlling type + of the thunk is the one expected by the GCC backend. + (Make_Secondary_DT, Register_Primitive): Adding the new formal + to the calls to Expand_Interface_Thunk. + * exp_ch6.adb (Register_Predefined_DT_Entry): Adding the new + formal to the call to Expand_Interface_Thunk. + * exp_intr.adb (Expand_Unc_Deallocation): When deallocating a + controlled type and the call to unchecked deallocation is + performed with a pointer to one of the convered interface types, + displace the pointer to the object to reference the base of the + object to deallocate its memory. + * gcc-interface/trans.c (maybe_make_gnu_thunk): Assert that the + controlling type of the thunk is an interface type. + +2019-12-13 Bob Duff <duff@adacore.com> + + * exp_attr.adb (Is_Available): Remove this function, and replace + all calls with RTE_Available. RTE_Available will return True if + "not Configurable_Run_Time_Mode". Remove the "???" comment. + +2019-12-13 Ed Schonberg <schonberg@adacore.com> + + * sem_ch7.adb (Analyze_Package_Body_Helper): Do not call + Declare_Inherited_Private_Subprograms on s child body: the + required operations have already been created when analyzing the + corresponding package declaration. This prevents a redeclaration + of inehrited operation, and a crash when inserting the new + operation in the current scope. + +2019-12-13 Yannick Moy <moy@adacore.com> + + * sem_prag.adb (Analyze_Depends_In_Decl_Part, + Analyze_Global_In_Decl_Part, + Analyze_Refined_Depends_In_Decl_Part, + Analyze_Refined_Global_In_Decl_Part, Check_Missing_Part_Of): + Skip redundant checking involving visibility inside + instantiations. + +2019-12-13 Yannick Moy <moy@adacore.com> + + * sem_res.adb (Resolve_Call): Prevent inlining inside while loop + conditions. + * sem_util.adb, sem_util.ads (In_While_Loop_Condition): New + query function. + +2019-12-13 Bob Duff <duff@adacore.com> + + * impunit.ads: Add Ada_202X_Unit. + * impunit.adb: Add a table Non_Imp_File_Names_2X analogous to + the other tables. Add code to search this table. + * opt.ads: Add Warn_On_Ada_202X_Compatibility flag, currently + always True. + * sem_ch10.adb (Analyze_With_Clause): Give a warning if an Ada + 2020 unit is with-ed when Ada_Version < Ada_2020. Change 'if' + to 'case': Full coverage rules rule. + +2019-12-13 Bob Duff <duff@adacore.com> + + * rtsfind.ads: Minor comment fix. + +2019-12-13 Gary Dismukes <dismukes@adacore.com> + + * sem_util.adb (Scope_Within): For the case of checking for a + task type procedure, check the Implementation_Base_Type of Curr. + (Scope_Within_Or_Same): For the case of checking for a task type + procedure, check the Implementation_Base_Type of Curr. + +2019-12-13 Arnaud Charlet <charlet@adacore.com> + + * impunit.adb (Non_Imp_File_Names_12): Add + Ada.Containers.Vectors.Generic_Parallel_Sorting. + +2019-12-13 Justin Squirek <squirek@adacore.com> + + * sem_res.adb (Resolve_Allocator): Add calls to + Check_Cond_Expr_Accessibility when a conditional expression is + found. + (Check_Allocator_Discrim_Accessibility_Exprs): Created to + recursively traverse a potentially compound conditional + expression and perform accessibility checks for each + alternative. + * sem_util.adb (Dynamic_Accessibility_Level): Avoid use of + original node of the expression in question so we can handle + dynamic accessibility in the limited case of a constant folded + conditional expression. + +2019-12-13 Steve Baird <baird@adacore.com> + + * exp_ch4.adb (Expand_N_Op_Eq.Is_Equality): Move this function + from within Expand_N_Op_Eq.Find_Equality out to immediately + within Expand_N_Op_Eq in order to give it greater visibility. + Add a new Typ parameter (defaulted to Empty) which, if + non-empty, means the function will return False in the case of + an equality op for some other type. + * (Expand_N_Op_Eq.User_Defined_Primitive_Equality_Op): A new + function. Given an untagged record type, finds the corresponding + user-defined primitive equality op (if any). May return Empty. + Ignores visibility. + * (Expand_N_Op): For Ada2012 or later, check for presence of a + user-defined primitive equality op before falling back on the + usual predefined component-by-component comparison. If found, + then call the user-defined op instead. + +2019-12-13 Justin Squirek <squirek@adacore.com> + + * sem_ch6.adb (Check_Overriding_Indicator): Modify condition to + take into account the modification of the Is_Hidden flag within + generic instances. + (Verify_Overriding_Indicator): Add an exception for controlled + primitives within an instance. + +2019-12-13 Ed Schonberg <schonberg@adacore.com> + + * sinfo.ads, sinfo.adb (Aspect_On_Partial_View, + Set_Aspect_On_Partial_View): New flag for use by SPARK, to + indicate whether an aspect that appears on a type declaration + applies to the partial view of that type. + * sem_ch13.adb (Analyze_Aspect_Specification): Set new flag + appropriately. + +2019-12-12 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Same_Reprewentation): if the actual in a call is + a generic actual type, use its bsae type to determine whether a + change of representastion may be necessary for proper parameter + passing. + +2019-12-12 Ed Schonberg <schonberg@adacore.com> + + * sem_type.adb (Find_Unique_Type): A call to the universal + access equality operator requires one operand to be a universal + access, and the other to be an access type. There is no + requirement, as previously implied by this routine, that + pool-specific access types were illegal in this context. + +2019-12-12 Steve Baird <baird@adacore.com> + + * sem_ch6.adb + (New_Overloaded_Entity.Check_Conforming_Paramters): Add new + Conformance_Type parameter. With the value of + Subtype_Conformant, the behavior of Check_Conforming_Parameters + is unchanged. The call in Matching_Entry_Or_Subprogram to + instead passes in Type_Conformant. This corresponds to the use + of "type conformant" in Ada RM 9.4(11.4/3). + (New_Overloaded_Entity.Has_Matching_Entry_Or_Subprogram): Add + new Normalized_First_Parameter_Type function to help in ignoring + the distinction between protected and access-to-protected first + parameters when checking prefixed-view profile matching. Replace + computations of the type of the first parameter with calls to + this function as appropriate. + +2019-12-12 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb: (Analyze_Iterator_Specification): If the + iteration is over a slice, complete the resolution of its + bounds, which may be aebitrary expressions. The previous + pre-analysis may have created itypes for the slice but has not + performed the expansion that for example may introduce actions + that specify explicit dereferences and run-time checks. + +2019-12-12 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb: Improve error message for dispatching subprogram + formals. + +2019-12-12 Gary Dismukes <dismukes@adacore.com> + + * exp_ch9.adb (Build_Protected_Entry): Set the Scope of the new + block to be the entity of the procedure created for the entry. + +2019-12-12 Steve Baird <baird@adacore.com> + + * sem_ch10.adb (Install_With_Clause): Check for the case of a + circular dependency involving a predefined (or GNAT-defined) + unit and handle that case by generating an appropropriate error + message. + +2019-12-12 Gary Dismukes <dismukes@adacore.com> + + * sem_ch4.adb, sem_res.adb: Minor reformatting. + +2019-12-12 Justin Squirek <squirek@adacore.com> + + * sem_ch4.adb (Analyze_One_Call): Add condition to check for + incorrectly resolved hidden controlled primitives. + +2019-12-12 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb: Fix processing of standard predefined operators. + +2019-12-12 Piotr Trojanek <trojanek@adacore.com> + + * libgnarl/a-dispat.ads (Yield): Update Global contract. + +2019-12-12 Piotr Trojanek <trojanek@adacore.com> + + * libgnat/g-altive.ads: Fix typo in comment. + * bindo-graphs.adb: Fix repeated words in comment. + * exp_ch4.adb: Likewise. + * exp_ch5.adb: Likewise. + * exp_ch7.adb: Likewise. + * exp_pakd.adb: Likewise. + * exp_unst.adb: Likewise. + * exp_util.adb: Likewise. + * freeze.adb: Likewise. + * inline.adb: Likewise. + * layout.adb: Likewise. + * sem_ch12.adb: Likewise. + * sem_ch13.adb: Likewise. + * sem_ch4.adb: Likewise. + * sem_ch9.adb: Likewise. + * sem_elab.adb: Likewise. + * doc/gnat_ugn/gnat_and_program_execution.rst: Fix repeated + words in user documentation. + * gnat_ugn.texi: Regenerate. + +2019-12-12 Eric Botcazou <ebotcazou@adacore.com> + + * exp_attr.adb (Expand_Size_Attribute): Look directly at the + prefix to detect the bit-packed slices. Apply the checks last + in case the attribute needs to be processed by the back-end. + * exp_ch4.adb (Expand_N_Slice): Do not create a temporary for + a prefix of the Size attribute. + +2019-12-12 Steve Baird <baird@adacore.com> + + * sem_ch12.adb + (Instantiate_Type.Validate_Derived_Type_Instance): Implement the + legality check of AI12-0036 + +2019-12-12 Ed Schonberg <schonberg@adacore.com> + + * sem_ch10.adb (Analyze_Subunit): Fix spurious visibility error + on subunit with optimization. + +2019-12-12 Arnaud Charlet <charlet@adacore.com> + + * raise-gcc.c (__gnat_personality_v0): Define for SEH. + +2019-12-12 Gary Dismukes <dismukes@adacore.com> + + * exp_ch9.adb (Build_Protected_Entry): Analyze the block created + to hold the declarations and statements of the protected entry + body right after it's created, and then call Reset_Scopes_To on + that block to reset the Scope of nested entities to the block + scope. + (Reset_Scope): Add handling for N_Freeze_Entity nodes, calling + Reset_Scopes recursively on the Actions of such nodes. Also, for + subprogram bodies that are encountered that might not have a + separate declaration (such as type init procedures), reset the + Scope of the subprogram's entity. + +2019-12-12 Justin Squirek <squirek@adacore.com> + + * sem_attr.adb (Analyze_Attribute): Add error message for + invalid usage of Attribute_Result. + +2019-12-12 Bob Duff <duff@adacore.com> + + * sem_attr.adb (Eval_Attribute): Never mark T'Descriptor_Size as + static, even if T is a static subtype, because otherwise we will + request the value of the attribute, which will crash because we + have not evaluated it. + +2019-12-12 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_N_Assognment_Statement): Extend the + processing involving private types with unknown discriminants to + handle the case where the full view of the type is an + unconstrained array type. + +2019-12-12 Bob Duff <duff@adacore.com> + + * sem_ch4.adb (Transform_Object_Operation): Deal properly with + prefix notation in instances. + +2019-12-12 Claire Dross <dross@adacore.com> + + * libgnat/a-cofove.adb, libgnat/a-cfinve.adb (Find_Index): Use + Extended_Index for call to Last. + +2019-12-12 Gary Dismukes <dismukes@adacore.com> + + * sem_ch3.adb, sem_util.adb: Minor reformatting. + +2019-12-12 Bob Duff <duff@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Update gnatmetric + documentation for average lengths + +2019-12-12 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Constrain_Access): Remove obsolete comments and + warning concerning component types of an access type whose + designated type is a constrained record type. (Such constraints + were previously ignored). Set scope of itype for component to + the scope of the enclosing record. + * sem_ch4.adb: Remove call to Set_Ekind. + * sem_util.adb (Build_Actual_Subtype_Of_Component): Handle + components whose type is an access to a constrained + discriminant, where the constraints may be given by the + discriminants of the enclosing type. New subprogram + Build_Access_Record_Constraint. + +2019-12-12 Justin Squirek <squirek@adacore.com> + + * exp_ch6.adb (Expand_Call_Helper): Added null case for + 'Loop_Entry, 'Old, and 'Result when calculating whether to + create extra accessibility parameters. + * sem_util.adb (Dynamic_Accessibility_Level): Added null case + for 'Loop_Entry, 'Old, and 'Result when calculating + accessibility level based on access-valued attributes. Also + added special handling for uses of 'Loop_Entry when used in its + indexed component form. + +2019-12-12 Arnaud Charlet <charlet@adacore.com> + + * raise-gcc.c: Remove references to VMS + +2019-12-12 Eric Botcazou <ebotcazou@adacore.com> + + * atree.ads, comperr.ads, debug.ads, einfo.ads, elists.ads, + err_vars.ads, errout.ads, exp_ch11.ads, exp_code.ads, + exp_dbug.ads, exp_tss.ads, exp_util.ads, lib.ads, namet.ads, + nlists.ads, opt.ads, repinfo.ads, restrict.ads, scos.ads, + sem_aggr.ads, sem_aux.ads, sem_eval.ads, sem_util.ads, + sinfo.ads, sinput.ads, stringt.ads, targparm.ads, types.ads, + urealp.ads warnsw.ads: Add WARNING line(s) in commentary. + * atree.h, elists.h, namet.h, nlists.h, repinfo.h, scos.h, + stringt.h, types.h, uintp.h, urealp.h: Tidy up. + * fe.h: Likewise. Document WARNING mark. + +2019-12-12 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/g-comlin.ads (Get_Argument): New routine similar to + original Get_Argument but with one more out parameter + End_Of_Arguments. + (Get_Arguments): Comment improved. + * libgnat/g-comlin.adb (Get_Argument): Implementation taken from + original Get_Argument and improved. + (Get_Argument): Calls new routine Get_Argument with additional + parameter. + +2019-12-03 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (potential_alignment_gap): Delete. + (rest_of_record_type_compilation): Do not call above function. Use + the alignment of the field instead of that of its type, if need be. + When the original field has variable size, always lower the alignment + of the pointer type. Reset the bit-field status of the new field if + it does not encode a bit-field. + +2019-12-03 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (fold_convert_size): New function. + (fold_bit_position): Invoke it to do further folding. + +2019-12-03 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_subprog_type): With the Copy-In/ + Copy-Out mechanism, do not promote the mode of the return type to an + integral mode if it contains a field on a non-integral type and even + demote it for 64-bit targets. + +2019-11-25 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/92362 + * gcc-interface/trans.c (gnat_to_gnu) <N_Attribute_Definition_Clause>: + Use a temporary instead of clobbering the result with a freeze node. + +2019-11-25 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/92575 + * expect.c (__gnat_expect_poll [VMS, HPUX]): Fix typo. + +2019-11-06 Eric Botcazou <ebotcazou@adacore.com> + Alexandre Oliva <oliva@adacore.com> + + * gcc-interface/misc.c (callgraph_info_file): Delete. + +2019-10-27 Jakub Jelinek <jakub@redhat.com> + + * locales.c (iso_3166): Add missing comma after "United-States". + 2019-10-15 Arnaud Charlet <charlet@adacore.com> * Makefile.rtl (a-except.o): Put -O1 earlier so that it can be diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index e6617e9..491cde3 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -309,6 +309,8 @@ package Atree is -- switch -gnatQ is set. Initialized to zero at the start of compilation. -- Initialized for -gnatVa use, see comment above. + -- WARNING: There is a matching C declaration of this variable in fe.h + Total_Errors_Detected : Nat := 0; -- Number of errors detected so far. Includes count of serious errors and -- non-serious errors, so this value is always greater than or equal to the diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index 704ae9b..9187583 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -23,9 +23,9 @@ * * ****************************************************************************/ -/* This is the C header corresponding to the Ada package specification for - Atree. It also contains the implementations of inlined functions from the - package body for Atree. It was generated manually from atree.ads and +/* This is the C header that corresponds to the Ada package specification for + Atree. It also contains the implementation of inlined functions from the + package body for Atree. It was created manually from atree.ads and atree.adb and must be kept synchronized with changes in these files. Note that only routines for reading the tree are included, since the tree diff --git a/gcc/ada/bindo-graphs.adb b/gcc/ada/bindo-graphs.adb index e7585e2..7802e7d 100644 --- a/gcc/ada/bindo-graphs.adb +++ b/gcc/ada/bindo-graphs.adb @@ -1676,7 +1676,7 @@ package body Bindo.Graphs is -- successor and predecessor are kept consistent in both cases, and -- Add_Edge_With_Return will prevent the creation of the second edge. - -- Assume that that no Body_Before_Spec is necessary + -- Assume that no Body_Before_Spec is necessary Edge := No_Library_Graph_Edge; diff --git a/gcc/ada/comperr.ads b/gcc/ada/comperr.ads index d770419..2992e7d 100644 --- a/gcc/ada/comperr.ads +++ b/gcc/ada/comperr.ads @@ -50,6 +50,8 @@ package Comperr is -- for a GCC abort and false for a front end exception (with a possible -- message stored in TSD.Current_Excep). + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Delete_SCIL_Files; -- Delete SCIL files associated with the main unit diff --git a/gcc/ada/debug.ads b/gcc/ada/debug.ads index 0ad6920..2bbaae6 100644 --- a/gcc/ada/debug.ads +++ b/gcc/ada/debug.ads @@ -48,6 +48,8 @@ package Debug is -- is contained in the body of Debug rather than the spec, so that we don't -- have to recompile the world when a new debug flag is added. + -- WARNING: There is a matching C declaration of a few flags in fe.h + Debug_Flag_A : Boolean := False; Debug_Flag_B : Boolean := False; Debug_Flag_C : Boolean := False; diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index bf0a9d4..6d0bdd8 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -3057,7 +3057,9 @@ different ways: particular family of scalar types using the optional arguments of the pragma. The compile-time approach is intended to optimize the generated code for the - pragma, by possibly using fast operations such as ``memset``. + pragma, by possibly using fast operations such as ``memset``. Note that such + optimizations require using values where the bytes all have the same binary + representation. * At bind time, the programmer has several options: @@ -3077,7 +3079,7 @@ different ways: The bind-time approach is intended to provide fast turnaround for testing with different values, without having to recompile the program. -* At execution time, the programmer can speify the invalid values using an +* At execution time, the programmer can specify the invalid values using an environment variable. See the GNAT User's Guide for details. The execution-time approach is intended to provide fast turnaround for @@ -7425,8 +7427,8 @@ Syntax: This is similar in effect to pragma Volatile, except that any reference to the object is guaranteed to be done only with instructions that read or write all the bits of the object. Furthermore, if the object is of a composite type, -then any reference to a component of the object is guaranteed to read and/or -write all the bits of the object. +then any reference to a subcomponent of the object is guaranteed to read +and/or write all the bits of the object. The intention is that this be suitable for use with memory-mapped I/O devices on some machines. Note that there are two important respects in which this is @@ -7438,7 +7440,7 @@ is not to the whole object; the compiler is allowed (and generally will) access only part of the object in this case. It is not permissible to specify ``Atomic`` and ``Volatile_Full_Access`` for -the same object. +the same type or object. It is not permissible to specify ``Volatile_Full_Access`` for a composite (record or array) type or object that has at least one ``Aliased`` component. 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 cae61e9..0fb9bdd 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -1214,8 +1214,7 @@ for more information. Profiling ========= -This section describes how to use the the ``gprof`` profiler tool on Ada -programs. +This section describes how to use the ``gprof`` profiler tool on Ada programs. .. index:: ! gprof .. index:: Profiling diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst index 56d4869..6e836a7 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst @@ -2022,8 +2022,7 @@ Alternatively, you may run the script using the following command line: and/or format effectors (blank lines) * the average number of code lines in subprogram bodies, task bodies, - entry bodies and statement sequences in package bodies (this metric - is only computed across the whole set of the analyzed units) + entry bodies and statement sequences in package bodies ``gnatmetric`` sums the values of the line metrics for all the files being processed and then generates the cumulative results. The tool @@ -2098,8 +2097,7 @@ Alternatively, you may run the script using the following command line: :switch:`--lines-average` Report the average number of code lines in subprogram bodies, task bodies, - entry bodies and statement sequences in package bodies. The metric is - reported for the whole set of processed Ada sources only. + entry bodies and statement sequences in package bodies. :switch:`--no-lines-average` diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 5366631..0aa7e00 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -929,12 +929,12 @@ package Einfo is -- -- In this case, if primitive operations have been declared for R, at -- the point of declaration of G, then the Derived_Type_Link of R is set --- to point to the entity for G. This is used to generate warnings for --- rep clauses that appear later on for R, which might result in an --- unexpected implicit conversion operation. +-- to point to the entity for G. This is used to generate warnings and +-- errors for rep clauses that appear later on for R, which might result +-- in an unexpected (or illegal) implicit conversion operation. -- -- Note: if there is more than one such derived type, the link will point --- to the last one (this is only used in generating warning messages). +-- to the last one. -- Designated_Type (synthesized) -- Applies to access types. Returns the designated type. Differs from @@ -7751,6 +7751,8 @@ package Einfo is -- Attribute Set Procedures -- ------------------------------ + -- WARNING: There is a matching C declaration of a few subprograms in fe.h + procedure Set_Abstract_States (Id : E; V : L); procedure Set_Accept_Address (Id : E; V : L); procedure Set_Access_Disp_Table (Id : E; V : L); @@ -8430,6 +8432,8 @@ package Einfo is -- value returned is the N_Attribute_Definition_Clause node, otherwise -- Empty is returned. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id; -- Searches the Rep_Item chain of entity E, for an instance of a pragma -- with the given pragma Id. If found, the value returned is the N_Pragma @@ -8500,6 +8504,8 @@ package Einfo is -- Test if the node N is the name of an entity (i.e. is an identifier, -- expanded name, or an attribute reference that returns an entity). + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Link_Entities (First : Entity_Id; Second : Entity_Id); -- Link entities First and Second in one entity chain. -- diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads index 7a8a08b..8a3b364 100644 --- a/gcc/ada/elists.ads +++ b/gcc/ada/elists.ads @@ -37,6 +37,9 @@ -- through the nodes themselves (using the Link field), which is more time -- and space efficient, but a node can be only one such list. +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file elists.h + with Types; use Types; with System; diff --git a/gcc/ada/elists.h b/gcc/ada/elists.h index 1b8588f..ac6efa2 100644 --- a/gcc/ada/elists.h +++ b/gcc/ada/elists.h @@ -23,9 +23,9 @@ * * ****************************************************************************/ -/* This is the C header corresponding to the Ada package specification for - Elists. It also contains the implementations of inlined functions from the - package body for Elists. It was generated manually from elists.ads and +/* This is the C header that corresponds to the Ada package specification for + Elists. It also contains the implementation of inlined functions from the + package body for Elists. It was created manually from elists.ads and elists.adb and must be kept synchronized with changes in these files. Note that only routines for reading the tree are included, since the diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads index 861a4ee..cc0ffeb 100644 --- a/gcc/ada/err_vars.ads +++ b/gcc/ada/err_vars.ads @@ -113,6 +113,8 @@ package Err_Vars is Error_Msg_Uint_2 : Uint; -- Uint values for ^ insertion characters in message + -- WARNING: There is a matching C declaration of these variables in fe.h + Error_Msg_Sloc : Source_Ptr; -- Source location for # insertion character in message diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 37db3e585..dfa6b86 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -734,6 +734,8 @@ package Errout is -- suppressed if the node N already has a message posted, or if it is a -- warning and N is an entity node for which warnings are suppressed. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Error_Msg_F (Msg : String; N : Node_Id); -- Similar to Error_Msg_N except that the message is placed on the first -- node of the construct N (First_Node (N)). Note that this procedure uses @@ -750,6 +752,8 @@ package Errout is -- will contain a & or } as usual to mark the insertion point. This -- routine can be called from the parser or the analyzer. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Error_Msg_FE (Msg : String; N : Node_Id; @@ -948,6 +952,8 @@ package Errout is -- This name is the identifier name as passed, cased according to the -- default identifier casing for the given file. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + Size_Too_Small_Message : constant String := "size for& too small, minimum allowed is ^"; -- This message is explicitly tested in Special_Msg_Delete in the package diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 3d3dd1b..60ad4d6 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -7499,7 +7499,7 @@ package body Exp_Aggr is return; end if; - -- If the pramga Aggregate_Individually_Assign is set, always convert to + -- If the pragma Aggregate_Individually_Assign is set, always convert to -- assignments. if Aggregate_Individually_Assign then diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 1459cfc..8c5981a 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2316,6 +2316,24 @@ package body Exp_Attr is when Attribute_Address => Address : declare Task_Proc : Entity_Id; + function Is_Unnested_Component_Init (N : Node_Id) return Boolean; + -- Returns True if N is being used to initialize a component of + -- an activation record object where the component corresponds to + -- the object denoted by the prefix of the attribute N. + + function Is_Unnested_Component_Init (N : Node_Id) return Boolean is + begin + return Present (Parent (N)) + and then Nkind (Parent (N)) = N_Assignment_Statement + and then Is_Entity_Name (Pref) + and then Present (Activation_Record_Component (Entity (Pref))) + and then Nkind (Name (Parent (N))) = N_Selected_Component + and then Entity (Selector_Name (Name (Parent (N)))) = + Activation_Record_Component (Entity (Pref)); + end Is_Unnested_Component_Init; + + -- Start of processing for Address + begin -- If the prefix is a task or a task type, the useful address is that -- of the procedure for the task body, i.e. the actual program unit. @@ -2379,13 +2397,19 @@ package body Exp_Attr is -- "displaced" to reference the tag associated with the interface -- type. In order to obtain the real address of such objects we -- generate a call to a run-time subprogram that returns the base - -- address of the object. + -- address of the object. This call is not generated in cases where + -- the attribute is being used to initialize a component of an + -- activation record object where the component corresponds to + -- prefix of the attribute (for back ends that require "unnesting" + -- of nested subprograms), since the address needs to be assigned + -- as-is to such components. elsif Is_Class_Wide_Type (Ptyp) and then Is_Interface (Underlying_Type (Ptyp)) and then Tagged_Type_Expansion and then not (Nkind (Pref) in N_Has_Entity and then Is_Subprogram (Entity (Pref))) + and then not Is_Unnested_Component_Init (N) then Rewrite (N, Make_Function_Call (Loc, @@ -7455,8 +7479,6 @@ package body Exp_Attr is -- All other cases are handled by the back end else - Apply_Universal_Integer_Attribute_Checks (N); - -- If Size is applied to a formal parameter that is of a packed -- array subtype, then apply Size to the actual subtype. @@ -7489,9 +7511,7 @@ package body Exp_Attr is -- System.Unsigned_Types.Packed_Byte for code generation purposes so -- the size is always rounded up in the back end. - elsif Nkind (Original_Node (Pref)) = N_Slice - and then Is_Bit_Packed_Array (Ptyp) - then + elsif Nkind (Pref) = N_Slice and then Is_Bit_Packed_Array (Ptyp) then Rewrite (N, Make_Op_Multiply (Loc, Make_Attribute_Reference (Loc, @@ -7503,6 +7523,9 @@ package body Exp_Attr is Analyze_And_Resolve (N, Typ); end if; + -- Apply the required checks last, after rewriting has taken place + + Apply_Universal_Integer_Attribute_Checks (N); return; end if; @@ -7819,31 +7842,6 @@ package body Exp_Attr is is Base_Typ : constant Entity_Id := Base_Type (Typ); Ent : constant Entity_Id := TSS (Typ, Nam); - - function Is_Available (Entity : RE_Id) return Boolean; - pragma Inline (Is_Available); - -- Function to check whether the specified run-time call is available - -- in the run time used. In the case of a configurable run time, it - -- is normal that some subprograms are not there. - -- - -- I don't understand this routine at all, why is this not just a - -- call to RTE_Available? And if for some reason we need a different - -- routine with different semantics, why is not in Rtsfind ??? - - ------------------ - -- Is_Available -- - ------------------ - - function Is_Available (Entity : RE_Id) return Boolean is - begin - -- Assume that the unit will always be available when using a - -- "normal" (not configurable) run time. - - return not Configurable_Run_Time_Mode or else RTE_Available (Entity); - end Is_Available; - - -- Start of processing for Find_Stream_Subprogram - begin if Present (Ent) then return Ent; @@ -7860,7 +7858,7 @@ package body Exp_Attr is -- that stream routines for string types are not present (they require -- file system support). In this case, the specific stream routines for -- strings are not used, relying on the regular stream mechanism - -- instead. That is why we include the test Is_Available when dealing + -- instead. That is why we include the test RTE_Available when dealing -- with these cases. if not Is_Predefined_Unit (Current_Sem_Unit) then @@ -7872,22 +7870,22 @@ package body Exp_Attr is if Restriction_Active (No_Stream_Optimizations) then if Nam = TSS_Stream_Input - and then Is_Available (RE_Storage_Array_Input) + and then RTE_Available (RE_Storage_Array_Input) then return RTE (RE_Storage_Array_Input); elsif Nam = TSS_Stream_Output - and then Is_Available (RE_Storage_Array_Output) + and then RTE_Available (RE_Storage_Array_Output) then return RTE (RE_Storage_Array_Output); elsif Nam = TSS_Stream_Read - and then Is_Available (RE_Storage_Array_Read) + and then RTE_Available (RE_Storage_Array_Read) then return RTE (RE_Storage_Array_Read); elsif Nam = TSS_Stream_Write - and then Is_Available (RE_Storage_Array_Write) + and then RTE_Available (RE_Storage_Array_Write) then return RTE (RE_Storage_Array_Write); @@ -7904,22 +7902,22 @@ package body Exp_Attr is else if Nam = TSS_Stream_Input - and then Is_Available (RE_Storage_Array_Input_Blk_IO) + and then RTE_Available (RE_Storage_Array_Input_Blk_IO) then return RTE (RE_Storage_Array_Input_Blk_IO); elsif Nam = TSS_Stream_Output - and then Is_Available (RE_Storage_Array_Output_Blk_IO) + and then RTE_Available (RE_Storage_Array_Output_Blk_IO) then return RTE (RE_Storage_Array_Output_Blk_IO); elsif Nam = TSS_Stream_Read - and then Is_Available (RE_Storage_Array_Read_Blk_IO) + and then RTE_Available (RE_Storage_Array_Read_Blk_IO) then return RTE (RE_Storage_Array_Read_Blk_IO); elsif Nam = TSS_Stream_Write - and then Is_Available (RE_Storage_Array_Write_Blk_IO) + and then RTE_Available (RE_Storage_Array_Write_Blk_IO) then return RTE (RE_Storage_Array_Write_Blk_IO); @@ -7940,22 +7938,22 @@ package body Exp_Attr is if Restriction_Active (No_Stream_Optimizations) then if Nam = TSS_Stream_Input - and then Is_Available (RE_Stream_Element_Array_Input) + and then RTE_Available (RE_Stream_Element_Array_Input) then return RTE (RE_Stream_Element_Array_Input); elsif Nam = TSS_Stream_Output - and then Is_Available (RE_Stream_Element_Array_Output) + and then RTE_Available (RE_Stream_Element_Array_Output) then return RTE (RE_Stream_Element_Array_Output); elsif Nam = TSS_Stream_Read - and then Is_Available (RE_Stream_Element_Array_Read) + and then RTE_Available (RE_Stream_Element_Array_Read) then return RTE (RE_Stream_Element_Array_Read); elsif Nam = TSS_Stream_Write - and then Is_Available (RE_Stream_Element_Array_Write) + and then RTE_Available (RE_Stream_Element_Array_Write) then return RTE (RE_Stream_Element_Array_Write); @@ -7972,22 +7970,22 @@ package body Exp_Attr is else if Nam = TSS_Stream_Input - and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO) + and then RTE_Available (RE_Stream_Element_Array_Input_Blk_IO) then return RTE (RE_Stream_Element_Array_Input_Blk_IO); elsif Nam = TSS_Stream_Output - and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO) + and then RTE_Available (RE_Stream_Element_Array_Output_Blk_IO) then return RTE (RE_Stream_Element_Array_Output_Blk_IO); elsif Nam = TSS_Stream_Read - and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO) + and then RTE_Available (RE_Stream_Element_Array_Read_Blk_IO) then return RTE (RE_Stream_Element_Array_Read_Blk_IO); elsif Nam = TSS_Stream_Write - and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO) + and then RTE_Available (RE_Stream_Element_Array_Write_Blk_IO) then return RTE (RE_Stream_Element_Array_Write_Blk_IO); @@ -8008,22 +8006,22 @@ package body Exp_Attr is if Restriction_Active (No_Stream_Optimizations) then if Nam = TSS_Stream_Input - and then Is_Available (RE_String_Input) + and then RTE_Available (RE_String_Input) then return RTE (RE_String_Input); elsif Nam = TSS_Stream_Output - and then Is_Available (RE_String_Output) + and then RTE_Available (RE_String_Output) then return RTE (RE_String_Output); elsif Nam = TSS_Stream_Read - and then Is_Available (RE_String_Read) + and then RTE_Available (RE_String_Read) then return RTE (RE_String_Read); elsif Nam = TSS_Stream_Write - and then Is_Available (RE_String_Write) + and then RTE_Available (RE_String_Write) then return RTE (RE_String_Write); @@ -8040,22 +8038,22 @@ package body Exp_Attr is else if Nam = TSS_Stream_Input - and then Is_Available (RE_String_Input_Blk_IO) + and then RTE_Available (RE_String_Input_Blk_IO) then return RTE (RE_String_Input_Blk_IO); elsif Nam = TSS_Stream_Output - and then Is_Available (RE_String_Output_Blk_IO) + and then RTE_Available (RE_String_Output_Blk_IO) then return RTE (RE_String_Output_Blk_IO); elsif Nam = TSS_Stream_Read - and then Is_Available (RE_String_Read_Blk_IO) + and then RTE_Available (RE_String_Read_Blk_IO) then return RTE (RE_String_Read_Blk_IO); elsif Nam = TSS_Stream_Write - and then Is_Available (RE_String_Write_Blk_IO) + and then RTE_Available (RE_String_Write_Blk_IO) then return RTE (RE_String_Write_Blk_IO); @@ -8076,22 +8074,22 @@ package body Exp_Attr is if Restriction_Active (No_Stream_Optimizations) then if Nam = TSS_Stream_Input - and then Is_Available (RE_Wide_String_Input) + and then RTE_Available (RE_Wide_String_Input) then return RTE (RE_Wide_String_Input); elsif Nam = TSS_Stream_Output - and then Is_Available (RE_Wide_String_Output) + and then RTE_Available (RE_Wide_String_Output) then return RTE (RE_Wide_String_Output); elsif Nam = TSS_Stream_Read - and then Is_Available (RE_Wide_String_Read) + and then RTE_Available (RE_Wide_String_Read) then return RTE (RE_Wide_String_Read); elsif Nam = TSS_Stream_Write - and then Is_Available (RE_Wide_String_Write) + and then RTE_Available (RE_Wide_String_Write) then return RTE (RE_Wide_String_Write); @@ -8108,22 +8106,22 @@ package body Exp_Attr is else if Nam = TSS_Stream_Input - and then Is_Available (RE_Wide_String_Input_Blk_IO) + and then RTE_Available (RE_Wide_String_Input_Blk_IO) then return RTE (RE_Wide_String_Input_Blk_IO); elsif Nam = TSS_Stream_Output - and then Is_Available (RE_Wide_String_Output_Blk_IO) + and then RTE_Available (RE_Wide_String_Output_Blk_IO) then return RTE (RE_Wide_String_Output_Blk_IO); elsif Nam = TSS_Stream_Read - and then Is_Available (RE_Wide_String_Read_Blk_IO) + and then RTE_Available (RE_Wide_String_Read_Blk_IO) then return RTE (RE_Wide_String_Read_Blk_IO); elsif Nam = TSS_Stream_Write - and then Is_Available (RE_Wide_String_Write_Blk_IO) + and then RTE_Available (RE_Wide_String_Write_Blk_IO) then return RTE (RE_Wide_String_Write_Blk_IO); @@ -8144,22 +8142,22 @@ package body Exp_Attr is if Restriction_Active (No_Stream_Optimizations) then if Nam = TSS_Stream_Input - and then Is_Available (RE_Wide_Wide_String_Input) + and then RTE_Available (RE_Wide_Wide_String_Input) then return RTE (RE_Wide_Wide_String_Input); elsif Nam = TSS_Stream_Output - and then Is_Available (RE_Wide_Wide_String_Output) + and then RTE_Available (RE_Wide_Wide_String_Output) then return RTE (RE_Wide_Wide_String_Output); elsif Nam = TSS_Stream_Read - and then Is_Available (RE_Wide_Wide_String_Read) + and then RTE_Available (RE_Wide_Wide_String_Read) then return RTE (RE_Wide_Wide_String_Read); elsif Nam = TSS_Stream_Write - and then Is_Available (RE_Wide_Wide_String_Write) + and then RTE_Available (RE_Wide_Wide_String_Write) then return RTE (RE_Wide_Wide_String_Write); @@ -8176,22 +8174,22 @@ package body Exp_Attr is else if Nam = TSS_Stream_Input - and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO) + and then RTE_Available (RE_Wide_Wide_String_Input_Blk_IO) then return RTE (RE_Wide_Wide_String_Input_Blk_IO); elsif Nam = TSS_Stream_Output - and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO) + and then RTE_Available (RE_Wide_Wide_String_Output_Blk_IO) then return RTE (RE_Wide_Wide_String_Output_Blk_IO); elsif Nam = TSS_Stream_Read - and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO) + and then RTE_Available (RE_Wide_Wide_String_Read_Blk_IO) then return RTE (RE_Wide_Wide_String_Read_Blk_IO); elsif Nam = TSS_Stream_Write - and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO) + and then RTE_Available (RE_Wide_Wide_String_Write_Blk_IO) then return RTE (RE_Wide_Wide_String_Write_Blk_IO); diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads index e5d8e21..afc9a40 100644 --- a/gcc/ada/exp_ch11.ads +++ b/gcc/ada/exp_ch11.ads @@ -70,6 +70,8 @@ package Exp_Ch11 is -- a goto statement. If Local_Raise is defined, its entity is returned, -- if not, Empty is returned (in which case the call is silently skipped). + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id; -- This function is provided for use by the back end in conjunction with -- generation of Local_Raise calls when an exception raise is converted to @@ -77,11 +79,15 @@ package Exp_Ch11 is -- to determine which Rcheck_nn procedure to call. The returned result is -- the exception entity to be passed to Local_Raise. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Get_RT_Exception_Name (Code : RT_Exception_Code); -- This procedure is provided for use by the back end to obtain the name of -- the Rcheck procedure for Code. The name is appended to Namet.Name_Buffer -- without the __gnat_rcheck_ prefix. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id); -- This procedure is called whenever node N might cause the back end -- to generate a local raise for a local Constraint/Program/Storage_Error @@ -95,4 +101,6 @@ package Exp_Ch11 is -- Issues warning if No_Exception_Propagation restriction is set. N is the -- node for the handler. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + end Exp_Ch11; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 158dcb5..28d48ab 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7520,10 +7520,21 @@ package body Exp_Ch4 is -- build and analyze call, adding conversions if the operation is -- inherited. + function Is_Equality (Subp : Entity_Id; + Typ : Entity_Id := Empty) return Boolean; + -- Determine whether arbitrary Entity_Id denotes a function with the + -- right name and profile for an equality op, specifically for the + -- base type Typ if Typ is nonempty. + function Find_Equality (Prims : Elist_Id) return Entity_Id; -- Find a primitive equality function within primitive operation list -- Prims. + function User_Defined_Primitive_Equality_Op + (Typ : Entity_Id) return Entity_Id; + -- Find a user-defined primitive equality function for a given untagged + -- record type, ignoring visibility. Return Empty if no such op found. + function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean; -- Determines whether a type has a subcomponent of an unconstrained -- Unchecked_Union subtype. Typ is a record type. @@ -7772,6 +7783,43 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); end Build_Equality_Call; + ----------------- + -- Is_Equality -- + ----------------- + + function Is_Equality (Subp : Entity_Id; + Typ : Entity_Id := Empty) return Boolean is + Formal_1 : Entity_Id; + Formal_2 : Entity_Id; + begin + -- The equality function carries name "=", returns Boolean, and has + -- exactly two formal parameters of an identical type. + + if Ekind (Subp) = E_Function + and then Chars (Subp) = Name_Op_Eq + and then Base_Type (Etype (Subp)) = Standard_Boolean + then + Formal_1 := First_Formal (Subp); + Formal_2 := Empty; + + if Present (Formal_1) then + Formal_2 := Next_Formal (Formal_1); + end if; + + return + Present (Formal_1) + and then Present (Formal_2) + and then No (Next_Formal (Formal_2)) + and then Base_Type (Etype (Formal_1)) = + Base_Type (Etype (Formal_2)) + and then + (not Present (Typ) + or else Implementation_Base_Type (Etype (Formal_1)) = Typ); + end if; + + return False; + end Is_Equality; + ------------------- -- Find_Equality -- ------------------- @@ -7781,9 +7829,6 @@ package body Exp_Ch4 is -- Find an equality in a possible alias chain starting from primitive -- operation Prim. - function Is_Equality (Id : Entity_Id) return Boolean; - -- Determine whether arbitrary entity Id denotes an equality - --------------------------- -- Find_Aliased_Equality -- --------------------------- @@ -7807,39 +7852,6 @@ package body Exp_Ch4 is return Empty; end Find_Aliased_Equality; - ----------------- - -- Is_Equality -- - ----------------- - - function Is_Equality (Id : Entity_Id) return Boolean is - Formal_1 : Entity_Id; - Formal_2 : Entity_Id; - - begin - -- The equality function carries name "=", returns Boolean, and - -- has exactly two formal parameters of an identical type. - - if Ekind (Id) = E_Function - and then Chars (Id) = Name_Op_Eq - and then Base_Type (Etype (Id)) = Standard_Boolean - then - Formal_1 := First_Formal (Id); - Formal_2 := Empty; - - if Present (Formal_1) then - Formal_2 := Next_Formal (Formal_1); - end if; - - return - Present (Formal_1) - and then Present (Formal_2) - and then Etype (Formal_1) = Etype (Formal_2) - and then No (Next_Formal (Formal_2)); - end if; - - return False; - end Is_Equality; - -- Local variables Eq_Prim : Entity_Id; @@ -7869,6 +7881,47 @@ package body Exp_Ch4 is return Eq_Prim; end Find_Equality; + ---------------------------------------- + -- User_Defined_Primitive_Equality_Op -- + ---------------------------------------- + + function User_Defined_Primitive_Equality_Op + (Typ : Entity_Id) return Entity_Id + is + Enclosing_Scope : constant Node_Id := Scope (Typ); + E : Entity_Id; + begin + -- Prune this search by somehow not looking at decls that precede + -- the declaration of the first view of Typ (which might be a partial + -- view)??? + + for Private_Entities in Boolean loop + if Private_Entities then + if Ekind (Enclosing_Scope) /= E_Package then + exit; + end if; + E := First_Private_Entity (Enclosing_Scope); + + else + E := First_Entity (Enclosing_Scope); + end if; + + while Present (E) loop + if Is_Equality (E, Typ) then + return E; + end if; + E := Next_Entity (E); + end loop; + end loop; + + if Is_Derived_Type (Typ) then + return User_Defined_Primitive_Equality_Op + (Implementation_Base_Type (Etype (Typ))); + end if; + + return Empty; + end User_Defined_Primitive_Equality_Op; + ------------------------------------ -- Has_Unconstrained_UU_Component -- ------------------------------------ @@ -8190,6 +8243,15 @@ package body Exp_Ch4 is (Find_Equality (Primitive_Operations (Typl))); end if; + -- See AI12-0101 (which only removes a legality rule) and then + -- AI05-0123 (which then applies in the previously illegal case). + -- AI12-0101 is a binding interpretation. + + elsif Ada_Version >= Ada_2012 + and then Present (User_Defined_Primitive_Equality_Op (Typl)) + then + Build_Equality_Call (User_Defined_Primitive_Equality_Op (Typl)); + -- Ada 2005 (AI-216): Program_Error is raised when evaluating the -- predefined equality operator for a type which has a subcomponent -- of an Unchecked_Union type whose nominal subtype is unconstrained. @@ -11013,7 +11075,8 @@ package body Exp_Ch4 is -- 5. Prefix of an address attribute (this is an error which is caught -- elsewhere, and the expansion would interfere with generating the - -- error message). + -- error message) or of a size attribute (because 'Size may change + -- when applied to the temporary instead of the slice directly). if not Is_Packed (Typ) then @@ -11039,7 +11102,8 @@ package body Exp_Ch4 is return; elsif Nkind (Parent (N)) = N_Attribute_Reference - and then Attribute_Name (Parent (N)) = Name_Address + and then (Attribute_Name (Parent (N)) = Name_Address + or else Attribute_Name (Parent (N)) = Name_Size) then return; @@ -11838,7 +11902,7 @@ package body Exp_Ch4 is -- The case where the target type is an anonymous access type of -- a discriminant is excluded, because the level of such a type -- depends on the context and currently the level returned for such - -- types is zero, resulting in warnings about about check failures + -- types is zero, resulting in warnings about check failures -- in certain legal cases involving class-wide interfaces as the -- designated type (some cases, such as return statements, are -- checked at run time, but not clear if these are handled right @@ -12318,8 +12382,8 @@ package body Exp_Ch4 is -- Remove the unchecked expression node from the tree. Its job was simply -- to make sure that its constituent expression was handled with checks - -- off, and now that that is done, we can remove it from the tree, and - -- indeed must, since Gigi does not expect to see these nodes. + -- off, and now that is done, we can remove it from the tree, and indeed + -- must, since Gigi does not expect to see these nodes. procedure Expand_N_Unchecked_Expression (N : Node_Id) is Exp : constant Node_Id := Expression (N); @@ -12407,6 +12471,27 @@ package body Exp_Ch4 is end; end if; + -- Generate an extra temporary for cases unsupported by the C backend + + if Modify_Tree_For_C then + declare + Source : constant Node_Id := Unqual_Conv (Expression (N)); + Source_Typ : Entity_Id := Get_Full_View (Etype (Source)); + + begin + if Is_Packed_Array (Source_Typ) then + Source_Typ := Packed_Array_Impl_Type (Source_Typ); + end if; + + if Nkind (Source) = N_Function_Call + and then (Is_Composite_Type (Etype (Source)) + or else Is_Composite_Type (Target_Type)) + then + Force_Evaluation (Source); + end if; + end; + end if; + -- Nothing to do if conversion is safe if Safe_Unchecked_Type_Conversion (N) then diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 4bbe86a..b30171e 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1065,8 +1065,8 @@ package body Exp_Ch5 is end if; -- Reset the Analyzed flag, because the bounds of the index - -- type itself may be universal, and must must be reanalyzed - -- to acquire the proper type for the back end. + -- type itself may be universal, and must be reanalyzed to + -- acquire the proper type for the back end. Set_Analyzed (Cleft_Lo, False); Set_Analyzed (Cright_Lo, False); @@ -2409,14 +2409,23 @@ package body Exp_Ch5 is -- checking. Convert Lhs as well, otherwise the actual subtype might -- not be constructible. If the discriminants have defaults the type -- is unconstrained and there is nothing to check. + -- Ditto if a private type with unknown discriminants has a full view + -- that is an unconstrained array, in which case a length check is + -- needed. - elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs))) - and then Has_Discriminants (Typ) - and then not Has_Defaulted_Discriminants (Typ) - then - Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); - Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs)); - Apply_Discriminant_Check (Rhs, Typ, Lhs); + elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs))) then + if Has_Discriminants (Typ) + and then not Has_Defaulted_Discriminants (Typ) + then + Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); + Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs)); + Apply_Discriminant_Check (Rhs, Typ, Lhs); + + elsif Is_Array_Type (Typ) and then Is_Constrained (Typ) then + Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); + Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs)); + Apply_Length_Check (Rhs, Typ); + end if; -- In the access type case, we need the same discriminant check, and -- also range checks if we have an access to constrained array. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index b311322..c03cd7c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3389,6 +3389,15 @@ package body Exp_Ch6 is case Nkind (Prev_Orig) is when N_Attribute_Reference => case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is + -- Ignore 'Result, 'Loop_Entry, and 'Old as they can + -- be used to identify access objects and do not have + -- an effect on accessibility level. + + when Attribute_Loop_Entry + | Attribute_Old + | Attribute_Result + => + null; -- For X'Access, pass on the level of the prefix X @@ -7598,7 +7607,8 @@ package body Exp_Ch6 is and then Ekind (Node (Iface_DT_Ptr)) = E_Constant loop pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, + Iface => Related_Type (Node (Iface_DT_Ptr))); if Present (Thunk_Code) then Insert_Actions_After (N, New_List ( diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 297e27d..125eba6 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -376,7 +376,7 @@ package body Exp_Ch7 is procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id); -- Similarly, the declarations or statements in library-level packages may - -- have created blocks blocks with nested subprograms. Such a block must be + -- have created blocks with nested subprograms. Such a block must be -- transformed into a procedure followed by a call to it, so that unnesting -- can handle uplevel references within these nested subprograms (typically -- subprograms that handle finalization actions). This also applies to diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 720c1a9..60080e6 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -48,6 +48,7 @@ with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; +with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch9; use Sem_Ch9; @@ -3722,6 +3723,17 @@ package body Exp_Ch9 is Declarations => Decls, Handled_Statement_Sequence => Handled_Statement_Sequence (N))); + -- Analyze now and reset scopes for declarations so that Scope fields + -- currently denoting the entry will now denote the block scope, and + -- the block's scope will be set to the new procedure entity. + + Analyze_Statements (Bod_Stmts); + + Set_Scope (Entity (Identifier (First (Bod_Stmts))), Bod_Id); + + Reset_Scopes_To + (First (Bod_Stmts), Entity (Identifier (First (Bod_Stmts)))); + case Corresponding_Runtime_Package (Pid) is when System_Tasking_Protected_Objects_Entries => Append_To (Bod_Stmts, @@ -14977,7 +14989,27 @@ package body Exp_Ch9 is Next (Decl); end loop; + elsif Nkind (N) = N_Freeze_Entity then + + -- Scan the actions associated with a freeze node, which may + -- actually be declarations with entities that need to have + -- their scopes reset. + + Decl := First (Actions (N)); + while Present (Decl) loop + Reset_Scopes (Decl); + Next (Decl); + end loop; + elsif N /= Bod and then Nkind (N) in N_Proper_Body then + + -- A subprogram without a separate declaration may be encountered, + -- and we need to reset the subprogram's entity's scope. + + if Nkind (N) = N_Subprogram_Body then + Set_Scope (Defining_Entity (Specification (N)), E); + end if; + return Skip; end if; diff --git a/gcc/ada/exp_code.ads b/gcc/ada/exp_code.ads index 6c0cce7..f0b0111 100644 --- a/gcc/ada/exp_code.ads +++ b/gcc/ada/exp_code.ads @@ -38,6 +38,8 @@ package Exp_Code is -- Note that the implementations of these routines must not attempt -- to expand tables that are frozen on entry to Gigi. + -- WARNING: There is a matching C declaration of these subprograms in fe.h + function Is_Asm_Volatile (N : Node_Id) return Boolean; -- Given an N_Code_Statement node N, return True if Volatile=True is -- specified, and False if Volatile=False is specified (or set by default). diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index 93b9783..f2e2e60 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -441,6 +441,8 @@ package Exp_Dbug is -- generating code, since the necessary information for computing the -- proper external name is not available in this case. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + ------------------------------------- -- Encoding for translation into C -- ------------------------------------- @@ -926,6 +928,8 @@ package Exp_Dbug is -- if we are not generating code, since the necessary information for -- computing the proper encoded name is not available in this case. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + -------------- -- Renaming -- -------------- @@ -1391,6 +1395,8 @@ package Exp_Dbug is -- of the string in Name_Len, and an ASCII.NUL character stored following -- the name. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + --------------------------------- -- Subtypes of Variant Records -- --------------------------------- diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 84caa92..4663a08 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1850,7 +1850,8 @@ package body Exp_Disp is procedure Expand_Interface_Thunk (Prim : Node_Id; Thunk_Id : out Entity_Id; - Thunk_Code : out Node_Id) + Thunk_Code : out Node_Id; + Iface : Entity_Id) is Loc : constant Source_Ptr := Sloc (Prim); Actuals : constant List_Id := New_List; @@ -1912,12 +1913,38 @@ package body Exp_Disp is -- Use the interface type as the type of the controlling formal (see -- comment above). - if not Is_Controlling_Formal (Formal) or else Is_Predef_Op then + if not Is_Controlling_Formal (Formal) then Ftyp := Etype (Formal); Expr := New_Copy_Tree (Expression (Parent (Formal))); + + -- For predefined primitives the controlling type of the thunk is + -- the interface type passed by the caller (since they don't have + -- available the Interface_Alias attribute; see comment above). + + elsif Is_Predef_Op then + Ftyp := Iface; + Expr := Empty; + else Ftyp := Etype (Iface_Formal); Expr := Empty; + + -- Sanity check performed to ensure the proper controlling type + -- when the thunk has exactly one controlling parameter and it + -- comes first. In such case the GCC backend reuses the C++ + -- thunks machinery which perform a computation equivalent to + -- the code generated by the expander; for other cases the GCC + -- backend translates the expanded code unmodified. However, as + -- a generalization, the check is performed for all controlling + -- types. + + if Is_Access_Type (Ftyp) then + pragma Assert (Base_Type (Designated_Type (Ftyp)) = Iface); + null; + else + Ftyp := Base_Type (Ftyp); + pragma Assert (Ftyp = Iface); + end if; end if; Append_To (Formals, @@ -4073,7 +4100,8 @@ package body Exp_Disp is Alias (Prim); else - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + Expand_Interface_Thunk + (Prim, Thunk_Id, Thunk_Code, Iface); if Present (Thunk_Id) then Append_To (Result, Thunk_Code); @@ -4379,7 +4407,8 @@ package body Exp_Disp is Prim_Table (Prim_Pos) := Alias (Prim); else - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + Expand_Interface_Thunk + (Prim, Thunk_Id, Thunk_Code, Iface); if Present (Thunk_Id) then Prim_Pos := @@ -7507,7 +7536,7 @@ package body Exp_Disp is return L; end if; - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, Iface_Typ); if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) and then Present (Thunk_Code) diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 7295942..5c490df 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -242,7 +242,8 @@ package Exp_Disp is procedure Expand_Interface_Thunk (Prim : Node_Id; Thunk_Id : out Entity_Id; - Thunk_Code : out Node_Id); + Thunk_Code : out Node_Id; + Iface : Entity_Id); -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we -- generate additional subprograms (thunks) associated with each primitive -- Prim to have a layout compatible with the C++ ABI. The thunk displaces diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index c28982c..78555bf 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -988,9 +988,31 @@ package body Exp_Intr is -- are allowed, the generated code may lack block statements. if Needs_Fin then - Obj_Ref := - Make_Explicit_Dereference (Loc, - Prefix => Duplicate_Subexpr_No_Checks (Arg)); + + -- Ada 2005 (AI-251): In case of abstract interface type we displace + -- the pointer to reference the base of the object to deallocate its + -- memory, unless we're targetting a VM, in which case no special + -- processing is required. + + if Is_Interface (Directly_Designated_Type (Typ)) + and then Tagged_Type_Expansion + then + Obj_Ref := + Make_Explicit_Dereference (Loc, + Prefix => + Unchecked_Convert_To (Typ, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Base_Address), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + Duplicate_Subexpr_No_Checks (Arg)))))); + + else + Obj_Ref := + Make_Explicit_Dereference (Loc, + Prefix => Duplicate_Subexpr_No_Checks (Arg)); + end if; -- If the designated type is tagged, the finalization call must -- dispatch because the designated type may not be the actual type diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 2f45a72..7dcf241 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -1564,7 +1564,7 @@ package body Exp_Pakd is Silly_Boolean_Array_Xor_Test (N, R, Rtyp); end if; - -- Now that that silliness is taken care of, get packed array type + -- Now that silliness is taken care of, get packed array type Convert_To_PAT_Type (L); Convert_To_PAT_Type (R); diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads index 61f2685..91c0c67 100644 --- a/gcc/ada/exp_tss.ads +++ b/gcc/ada/exp_tss.ads @@ -150,6 +150,8 @@ package Exp_Tss is function Is_Init_Proc (E : Entity_Id) return Boolean; -- Version for init procs, same as Is_TSS (E, TSS_Init_Proc); + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean; -- Determines if given entity (E) is the name of a TSS identified by Nam diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index b25b449..1747281 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -27,6 +27,7 @@ with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; +with Exp_Util; use Exp_Util; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; @@ -413,11 +414,14 @@ package body Exp_Unst is then return; - -- Only unnest when generating code for the main source unit or if we're - -- unnesting for inline. + -- Only unnest when generating code for the main source unit or if + -- we're unnesting for inline. But in some Annex E cases the Sloc + -- points to a different unit, so also make sure that the Parent + -- isn't in something that we know we're generating code for. elsif not For_Inline and then not In_Extended_Main_Code_Unit (Subp_Body) + and then not In_Extended_Main_Code_Unit (Parent (Subp_Body)) then return; end if; @@ -526,8 +530,8 @@ package body Exp_Unst is procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id) is begin -- Entity name case. Make sure that the entity is declared - -- in a subprogram. This may not be the case for for a type - -- in a loop appearing in a precondition. + -- in a subprogram. This may not be the case for a type in a + -- loop appearing in a precondition. -- Exclude explicitly discriminants (that can appear -- in bounds of discriminated components). @@ -1801,7 +1805,7 @@ package body Exp_Unst is Comp : Entity_Id; Decl_Assign : Node_Id; - -- Assigment to set uplink, Empty if none + -- Assignment to set uplink, Empty if none Decl_ARECnT : Node_Id; Decl_ARECnPT : Node_Id; @@ -2345,6 +2349,18 @@ package body Exp_Unst is -- expect any exceptions) Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks); + + -- Generate an extra temporary to facilitate the C backend + -- processing this dereference + + if Opt.Modify_Tree_For_C + and then Nkind_In (Parent (UPJ.Ref), + N_Type_Conversion, + N_Unchecked_Type_Conversion) + then + Force_Evaluation (UPJ.Ref, Mode => Strict); + end if; + Pop_Scope; end Rewrite_One_Ref; end; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 36c900b..7bd90e7 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -9718,7 +9718,7 @@ package body Exp_Util is end if; -- Do not generate a check within an internal subprogram (stream - -- functions and the like, including including predicate functions). + -- functions and the like, including predicate functions). if Within_Internal_Subprogram then return Make_Null_Statement (Loc); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 02fb233..03008ba 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -599,6 +599,8 @@ package Exp_Util is -- record component containing the tag of Iface if T implements Iface or -- Empty if it does not. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id; -- Find the first primitive operation of a tagged type T with name Name. -- This function allows the use of a primitive operation which is not @@ -784,6 +786,8 @@ package Exp_Util is -- routine is useful for the case of a discriminated type, and testing for -- component overlap would be a pain. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean; -- Return True if Typ is a library level tagged type. Currently we use -- this information to build statically allocated dispatch tables. diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c index 349af3f..b8753ab 100644 --- a/gcc/ada/expect.c +++ b/gcc/ada/expect.c @@ -262,7 +262,7 @@ __gnat_expect_poll (int *fd, if ((status & 1) != 1) { ready = -1; - dead_process = i + 1; + *dead_process = i + 1; return ready; } } @@ -447,7 +447,7 @@ __gnat_expect_poll (int *fd, if (ei.request == TIOCCLOSE) { ioctl (fd[i], TIOCREQSET, &ei); - dead_process = i + 1; + *dead_process = i + 1; return -1; } diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index f62d67e..0ccd1a0 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -29,8 +29,14 @@ * * ****************************************************************************/ -/* This file contains declarations to access front-end functions and variables - used by gigi. +/* This is the C header that contains the declarations of Ada subprograms and + variables used by gigi and not declared in other C header files. It was + created manually from Ada specifications. The original Ada declarations + in these specifications must be marked with: + + "WARNING: There is a matching C declaration of this <entity_kind> in fe.h" + + where <entity_kind> is either "subprogram" or "variable". WARNING: functions taking String_Pointer parameters must abide by the rule documented alongside the definition of String_Pointer in types.h. */ @@ -41,23 +47,21 @@ extern "C" { /* atree: */ -#define Serious_Errors_Detected atree__serious_errors_detected +#define Serious_Errors_Detected atree__serious_errors_detected -/* comperr: */ +extern Nat Serious_Errors_Detected; -#define Compiler_Abort comperr__compiler_abort -extern int Compiler_Abort (String_Pointer, String_Pointer, Boolean) ATTRIBUTE_NORETURN; +/* comperr: */ -/* csets: */ +#define Compiler_Abort comperr__compiler_abort -#define Fold_Lower(C) csets__fold_lower[C] -#define Fold_Upper(C) csets__fold_upper[C] -extern char Fold_Lower[], Fold_Upper[]; +extern int Compiler_Abort (String_Pointer, String_Pointer, Boolean) ATTRIBUTE_NORETURN; /* debug: */ #define Debug_Flag_Dot_R debug__debug_flag_dot_r #define Debug_Flag_NN debug__debug_flag_nn + extern Boolean Debug_Flag_Dot_R; extern Boolean Debug_Flag_NN; @@ -81,59 +85,58 @@ extern void Set_Normalized_First_Bit (Entity_Id, Uint); extern void Set_Normalized_Position (Entity_Id, Uint); extern void Set_RM_Size (Entity_Id, Uint); -#define Is_Entity_Name einfo__is_entity_name +#define Is_Entity_Name einfo__is_entity_name + extern Boolean Is_Entity_Name (Node_Id); -#define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause +#define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause + extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, unsigned char); /* errout: */ -#define Error_Msg_N errout__error_msg_n -#define Error_Msg_NE errout__error_msg_ne -#define Set_Identifier_Casing errout__set_identifier_casing +#define Error_Msg_N errout__error_msg_n +#define Error_Msg_NE errout__error_msg_ne +#define Set_Identifier_Casing errout__set_identifier_casing -extern void Error_Msg_N (String_Pointer, Node_Id); -extern void Error_Msg_NE (String_Pointer, Node_Id, Entity_Id); -extern void Set_Identifier_Casing (Char *, const Char *); +extern void Error_Msg_N (String_Pointer, Node_Id); +extern void Error_Msg_NE (String_Pointer, Node_Id, Entity_Id); +extern void Set_Identifier_Casing (Char *, const Char *); /* err_vars: */ -#define Error_Msg_Node_2 err_vars__error_msg_node_2 -#define Error_Msg_Uint_1 err_vars__error_msg_uint_1 -#define Error_Msg_Uint_2 err_vars__error_msg_uint_2 +#define Error_Msg_Uint_1 err_vars__error_msg_uint_1 +#define Error_Msg_Uint_2 err_vars__error_msg_uint_2 -extern Entity_Id Error_Msg_Node_2; -extern Uint Error_Msg_Uint_1; -extern Uint Error_Msg_Uint_2; -extern Nat Serious_Errors_Detected; +extern Uint Error_Msg_Uint_1; +extern Uint Error_Msg_Uint_2; /* exp_ch11: */ -#define Get_Local_Raise_Call_Entity exp_ch11__get_local_raise_call_entity -#define Get_RT_Exception_Entity exp_ch11__get_rt_exception_entity -#define Get_RT_Exception_Name exp_ch11__get_rt_exception_name -#define Warn_If_No_Local_Raise exp_ch11__warn_if_no_local_raise +#define Get_Local_Raise_Call_Entity exp_ch11__get_local_raise_call_entity +#define Get_RT_Exception_Entity exp_ch11__get_rt_exception_entity +#define Get_RT_Exception_Name exp_ch11__get_rt_exception_name +#define Warn_If_No_Local_Raise exp_ch11__warn_if_no_local_raise -extern Entity_Id Get_Local_Raise_Call_Entity (void); -extern Entity_Id Get_RT_Exception_Entity (int); -extern void Get_RT_Exception_Name (int); -extern void Warn_If_No_Local_Raise (int); +extern Entity_Id Get_Local_Raise_Call_Entity (void); +extern Entity_Id Get_RT_Exception_Entity (int); +extern void Get_RT_Exception_Name (int); +extern void Warn_If_No_Local_Raise (int); /* exp_code: */ -#define Asm_Input_Constraint exp_code__asm_input_constraint -#define Asm_Input_Value exp_code__asm_input_value -#define Asm_Output_Constraint exp_code__asm_output_constraint -#define Asm_Output_Variable exp_code__asm_output_variable -#define Asm_Template exp_code__asm_template -#define Clobber_Get_Next exp_code__clobber_get_next -#define Clobber_Setup exp_code__clobber_setup -#define Is_Asm_Volatile exp_code__is_asm_volatile -#define Next_Asm_Input exp_code__next_asm_input -#define Next_Asm_Output exp_code__next_asm_output -#define Setup_Asm_Inputs exp_code__setup_asm_inputs -#define Setup_Asm_Outputs exp_code__setup_asm_outputs +#define Asm_Input_Constraint exp_code__asm_input_constraint +#define Asm_Input_Value exp_code__asm_input_value +#define Asm_Output_Constraint exp_code__asm_output_constraint +#define Asm_Output_Variable exp_code__asm_output_variable +#define Asm_Template exp_code__asm_template +#define Clobber_Get_Next exp_code__clobber_get_next +#define Clobber_Setup exp_code__clobber_setup +#define Is_Asm_Volatile exp_code__is_asm_volatile +#define Next_Asm_Input exp_code__next_asm_input +#define Next_Asm_Output exp_code__next_asm_output +#define Setup_Asm_Inputs exp_code__setup_asm_inputs +#define Setup_Asm_Outputs exp_code__setup_asm_outputs extern Node_Id Asm_Input_Constraint (void); extern Node_Id Asm_Input_Value (void); @@ -150,22 +153,24 @@ extern void Setup_Asm_Outputs (Node_Id); /* exp_dbug: */ -#define Get_Encoded_Name exp_dbug__get_encoded_name -#define Get_External_Name exp_dbug__get_external_name +#define Get_Encoded_Name exp_dbug__get_encoded_name +#define Get_External_Name exp_dbug__get_external_name +#define Get_Variant_Encoding exp_dbug__get_variant_encoding -extern void Get_Encoded_Name (Entity_Id); -extern void Get_External_Name (Entity_Id, Boolean, String_Pointer); +extern void Get_Encoded_Name (Entity_Id); +extern void Get_External_Name (Entity_Id, Boolean, String_Pointer); +extern void Get_Variant_Encoding (Entity_Id); /* exp_tss: */ -#define Is_Init_Proc exp_tss__is_init_proc +#define Is_Init_Proc exp_tss__is_init_proc extern Boolean Is_Init_Proc (Entity_Id); /* exp_util: */ -#define Is_Fully_Repped_Tagged_Type exp_util__is_fully_repped_tagged_type -#define Find_Interface_Tag exp_util__find_interface_tag +#define Is_Fully_Repped_Tagged_Type exp_util__is_fully_repped_tagged_type +#define Find_Interface_Tag exp_util__find_interface_tag extern Boolean Is_Fully_Repped_Tagged_Type (Entity_Id); extern Entity_Id Find_Interface_Tag (Entity_Id, Entity_Id); @@ -175,26 +180,23 @@ extern Entity_Id Find_Interface_Tag (Entity_Id, Entity_Id); #define Cunit lib__cunit #define Ident_String lib__ident_string #define In_Extended_Main_Code_Unit lib__in_extended_main_code_unit -#define In_Same_Source_Unit lib__in_same_source_unit extern Node_Id Cunit (Unit_Number_Type); extern Node_Id Ident_String (Unit_Number_Type); extern Boolean In_Extended_Main_Code_Unit (Entity_Id); -extern Boolean In_Same_Source_Unit (Node_Id, Node_Id); /* opt: */ -#define Back_End_Inlining opt__back_end_inlining -#define Debug_Generated_Code opt__debug_generated_code -#define Exception_Extra_Info opt__exception_extra_info -#define Exception_Locations_Suppressed opt__exception_locations_suppressed -#define Exception_Mechanism opt__exception_mechanism -#define Float_Format opt__float_format -#define Generate_SCO_Instance_Table opt__generate_sco_instance_table -#define GNAT_Mode opt__gnat_mode -#define List_Representation_Info opt__list_representation_info -#define No_Strict_Aliasing_CP opt__no_strict_aliasing -#define Suppress_Checks opt__suppress_checks +#define Back_End_Inlining opt__back_end_inlining +#define Debug_Generated_Code opt__debug_generated_code +#define Exception_Extra_Info opt__exception_extra_info +#define Exception_Locations_Suppressed opt__exception_locations_suppressed +#define Exception_Mechanism opt__exception_mechanism +#define Generate_SCO_Instance_Table opt__generate_sco_instance_table +#define GNAT_Mode opt__gnat_mode +#define List_Representation_Info opt__list_representation_info +#define No_Strict_Aliasing_CP opt__no_strict_aliasing +#define Suppress_Checks opt__suppress_checks typedef enum { Front_End_SJLJ, Back_End_ZCX, Back_End_SJLJ @@ -205,122 +207,135 @@ extern Boolean Debug_Generated_Code; extern Boolean Exception_Extra_Info; extern Boolean Exception_Locations_Suppressed; extern Exception_Mechanism_Type Exception_Mechanism; -extern Char Float_Format; extern Boolean Generate_SCO_Instance_Table; extern Boolean GNAT_Mode; extern Int List_Representation_Info; extern Boolean No_Strict_Aliasing_CP; extern Boolean Suppress_Checks; -#define ZCX_Exceptions opt__zcx_exceptions -#define SJLJ_Exceptions opt__sjlj_exceptions -#define Front_End_Exceptions opt__front_end_exceptions -#define Back_End_Exceptions opt__back_end_exceptions +#define ZCX_Exceptions opt__zcx_exceptions +#define SJLJ_Exceptions opt__sjlj_exceptions +#define Front_End_Exceptions opt__front_end_exceptions +#define Back_End_Exceptions opt__back_end_exceptions -extern Boolean ZCX_Exceptions (void); -extern Boolean SJLJ_Exceptions (void); -extern Boolean Front_End_Exceptions (void); -extern Boolean Back_End_Exceptions (void); +extern Boolean ZCX_Exceptions (void); +extern Boolean SJLJ_Exceptions (void); +extern Boolean Front_End_Exceptions (void); +extern Boolean Back_End_Exceptions (void); /* restrict: */ -#define No_Exception_Handlers_Set restrict__no_exception_handlers_set -#define Check_No_Implicit_Heap_Alloc restrict__check_no_implicit_heap_alloc -#define Check_No_Implicit_Task_Alloc restrict__check_no_implicit_task_alloc -#define Check_No_Implicit_Protected_Alloc restrict__check_no_implicit_protected_alloc -#define Check_Elaboration_Code_Allowed restrict__check_elaboration_code_allowed -#define Check_Implicit_Dynamic_Code_Allowed restrict__check_implicit_dynamic_code_allowed - -extern Boolean No_Exception_Handlers_Set (void); -extern void Check_No_Implicit_Heap_Alloc (Node_Id); -extern void Check_No_Implicit_Task_Alloc (Node_Id); -extern void Check_No_Implicit_Protected_Alloc (Node_Id); -extern void Check_Elaboration_Code_Allowed (Node_Id); -extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id); +#define Check_Elaboration_Code_Allowed \ + restrict__check_elaboration_code_allowed +#define Check_Implicit_Dynamic_Code_Allowed \ + restrict__check_implicit_dynamic_code_allowed +#define Check_No_Implicit_Heap_Alloc \ + restrict__check_no_implicit_heap_alloc +#define Check_No_Implicit_Protected_Alloc \ + restrict__check_no_implicit_protected_alloc +#define Check_No_Implicit_Task_Alloc \ + restrict__check_no_implicit_task_alloc +#define No_Exception_Handlers_Set \ + restrict__no_exception_handlers_set + +extern void Check_Elaboration_Code_Allowed (Node_Id); +extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id); +extern void Check_No_Implicit_Heap_Alloc (Node_Id); +extern void Check_No_Implicit_Protected_Alloc (Node_Id); +extern void Check_No_Implicit_Task_Alloc (Node_Id); +extern Boolean No_Exception_Handlers_Set (void); /* sem_aggr: */ -#define Is_Others_Aggregate sem_aggr__is_others_aggregate +#define Is_Others_Aggregate sem_aggr__is_others_aggregate -extern Boolean Is_Others_Aggregate (Node_Id); +extern Boolean Is_Others_Aggregate (Node_Id); /* sem_aux: */ -#define Ancestor_Subtype sem_aux__ancestor_subtype -#define Constant_Value sem_aux__constant_value -#define First_Discriminant sem_aux__first_discriminant -#define First_Stored_Discriminant sem_aux__first_stored_discriminant -#define First_Subtype sem_aux__first_subtype -#define Is_By_Reference_Type sem_aux__is_by_reference_type -#define Is_Derived_Type sem_aux__is_derived_type - -extern Entity_Id Ancestor_Subtype (Entity_Id); -extern Node_Id Constant_Value (Entity_Id); -extern Entity_Id First_Discriminant (Entity_Id); -extern Entity_Id First_Stored_Discriminant (Entity_Id); -extern Entity_Id First_Subtype (Entity_Id); -extern Boolean Is_By_Reference_Type (Entity_Id); -extern Boolean Is_Derived_Type (Entity_Id); +#define Ancestor_Subtype sem_aux__ancestor_subtype +#define Constant_Value sem_aux__constant_value +#define First_Discriminant sem_aux__first_discriminant +#define First_Stored_Discriminant sem_aux__first_stored_discriminant +#define First_Subtype sem_aux__first_subtype +#define Is_By_Reference_Type sem_aux__is_by_reference_type +#define Is_Derived_Type sem_aux__is_derived_type + +extern Entity_Id Ancestor_Subtype (Entity_Id); +extern Node_Id Constant_Value (Entity_Id); +extern Entity_Id First_Discriminant (Entity_Id); +extern Entity_Id First_Stored_Discriminant (Entity_Id); +extern Entity_Id First_Subtype (Entity_Id); +extern Boolean Is_By_Reference_Type (Entity_Id); +extern Boolean Is_Derived_Type (Entity_Id); /* sem_eval: */ #define Compile_Time_Known_Value sem_eval__compile_time_known_value -#define Expr_Value sem_eval__expr_value -#define Expr_Value_S sem_eval__expr_value_s #define Is_OK_Static_Expression sem_eval__is_ok_static_expression -#define Is_OK_Static_Subtype sem_eval__is_ok_static_subtype -extern Uint Expr_Value (Node_Id); -extern Node_Id Expr_Value_S (Node_Id); -extern Boolean Compile_Time_Known_Value (Node_Id); -extern Boolean Is_OK_Static_Expression (Node_Id); -extern Boolean Is_OK_Static_Subtype (Entity_Id); +extern Boolean Compile_Time_Known_Value (Node_Id); +extern Boolean Is_OK_Static_Expression (Node_Id); /* sem_util: */ #define Defining_Entity sem_util__defining_entity #define First_Actual sem_util__first_actual -#define Next_Actual sem_util__next_actual #define Is_Atomic_Object sem_util__is_atomic_object #define Is_Variable_Size_Record sem_util__is_variable_size_record #define Is_Volatile_Object sem_util__is_volatile_object +#define Next_Actual sem_util__next_actual #define Requires_Transient_Scope sem_util__requires_transient_scope extern Entity_Id Defining_Entity (Node_Id); extern Node_Id First_Actual (Node_Id); -extern Node_Id Next_Actual (Node_Id); extern Boolean Is_Atomic_Object (Node_Id); extern Boolean Is_Variable_Size_Record (Entity_Id Id); extern Boolean Is_Volatile_Object (Node_Id); +extern Node_Id Next_Actual (Node_Id); extern Boolean Requires_Transient_Scope (Entity_Id); /* sinfo: */ #define End_Location sinfo__end_location -#define Set_Has_No_Elaboration_Code sinfo__set_has_no_elaboration_code +#define Set_Has_No_Elaboration_Code sinfo__set_has_no_elaboration_code #define Set_Present_Expr sinfo__set_present_expr extern Source_Ptr End_Location (Node_Id); extern void Set_Has_No_Elaboration_Code (Node_Id, Boolean); extern void Set_Present_Expr (Node_Id, Uint); +/* sinput: */ + +#define Debug_Source_Name sinput__debug_source_name +#define Get_Column_Number sinput__get_column_number +#define Get_Logical_Line_Number sinput__get_logical_line_number +#define Get_Source_File_Index sinput__get_source_file_index + +extern File_Name_Type Debug_Source_Name (Source_File_Index); +extern Column_Number_Type Get_Column_Number (Source_Ptr); +extern Line_Number_Type Get_Logical_Line_Number (Source_Ptr); +extern Source_File_Index Get_Source_File_Index (Source_Ptr); + /* targparm: */ -#define Backend_Overflow_Checks_On_Target targparm__backend_overflow_checks_on_target -#define Machine_Overflows_On_Target targparm__machine_overflows_on_target -#define Signed_Zeros_On_Target targparm__signed_zeros_on_target -#define Stack_Check_Probes_On_Target targparm__stack_check_probes_on_target -#define Stack_Check_Limits_On_Target targparm__stack_check_limits_on_target +#define Machine_Overflows_On_Target \ + targparm__machine_overflows_on_target +#define Signed_Zeros_On_Target \ + targparm__signed_zeros_on_target +#define Stack_Check_Limits_On_Target \ + targparm__stack_check_limits_on_target +#define Stack_Check_Probes_On_Target \ + targparm__stack_check_probes_on_target -extern Boolean Backend_Overflow_Checks_On_Target; extern Boolean Machine_Overflows_On_Target; extern Boolean Signed_Zeros_On_Target; -extern Boolean Stack_Check_Probes_On_Target; extern Boolean Stack_Check_Limits_On_Target; +extern Boolean Stack_Check_Probes_On_Target; /* warnsw: */ -#define Warn_On_Questionable_Layout warnsw__warn_on_questionable_layout +#define Warn_On_Questionable_Layout warnsw__warn_on_questionable_layout extern Boolean Warn_On_Questionable_Layout; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5e1b775..add4153 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1502,7 +1502,7 @@ package body Freeze is -- In GNATprove mode this is where we can collect the inherited -- conditions, because we do not create the Check pragmas that - -- normally convey the the modified class-wide conditions on + -- normally convey the modified class-wide conditions on -- overriding operations. if GNATprove_Mode then diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 29c5a8e..b83f38c 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -5620,6 +5620,32 @@ gnat_to_gnu_profile_type (Entity_Id gnat_type) return gnu_type; } +/* Return true if TYPE contains only integral data, recursively if need be. */ + +static bool +type_contains_only_integral_data (tree type) +{ + switch (TREE_CODE (type)) + { + case RECORD_TYPE: + case UNION_TYPE: + case QUAL_UNION_TYPE: + for (tree field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) + if (!type_contains_only_integral_data (TREE_TYPE (field))) + return false; + return true; + + case ARRAY_TYPE: + case COMPLEX_TYPE: + return type_contains_only_integral_data (TREE_TYPE (type)); + + default: + return INTEGRAL_TYPE_P (type); + } + + gcc_unreachable (); +} + /* Return a GCC tree for a subprogram type corresponding to GNAT_SUBPROG. DEFINITION is true if this is for a subprogram being defined. DEBUG_INFO_P is true if we need to write debug information for other types that we may @@ -5649,8 +5675,8 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, the TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */ tree gnu_cico_list = NULL_TREE; tree gnu_cico_return_type = NULL_TREE; - /* Fields in return type of procedure with copy-in copy-out parameters. */ - tree gnu_field_list = NULL_TREE; + tree gnu_cico_field_list = NULL_TREE; + bool gnu_cico_only_integral_type = true; /* The semantics of "pure" in Ada essentially matches that of "const" or "pure" in GCC. In particular, both properties are orthogonal to the "nothrow" property if the EH circuitry is explicit in the @@ -5976,9 +6002,11 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, NULL_TREE, 0, 0); Sloc_to_locus (Sloc (gnat_subprog), &DECL_SOURCE_LOCATION (gnu_field)); - gnu_field_list = gnu_field; + gnu_cico_field_list = gnu_field; gnu_cico_list = tree_cons (gnu_field, void_type_node, NULL_TREE); + if (!type_contains_only_integral_data (gnu_return_type)) + gnu_cico_only_integral_type = false; } TYPE_NAME (gnu_cico_return_type) = get_identifier ("RETURN"); @@ -5995,9 +6023,11 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, 0, 0); Sloc_to_locus (Sloc (gnat_param), &DECL_SOURCE_LOCATION (gnu_field)); - DECL_CHAIN (gnu_field) = gnu_field_list; - gnu_field_list = gnu_field; + DECL_CHAIN (gnu_field) = gnu_cico_field_list; + gnu_cico_field_list = gnu_field; gnu_cico_list = tree_cons (gnu_field, gnu_param, gnu_cico_list); + if (!type_contains_only_integral_data (gnu_param_type)) + gnu_cico_only_integral_type = false; } } @@ -6014,12 +6044,14 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, since structures are incomplete for the back-end. */ else if (Convention (gnat_subprog) != Convention_Stubbed) { - finish_record_type (gnu_cico_return_type, nreverse (gnu_field_list), + finish_record_type (gnu_cico_return_type, + nreverse (gnu_cico_field_list), 0, false); - /* Try to promote the mode of the return type if it is passed - in registers, again to speed up accesses. */ + /* Try to promote the mode if the return type is fully returned + in integer registers, again to speed up accesses. */ if (TYPE_MODE (gnu_cico_return_type) == BLKmode + && gnu_cico_only_integral_type && !targetm.calls.return_in_memory (gnu_cico_return_type, NULL_TREE)) { @@ -6042,6 +6074,17 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, } } + /* But demote the mode if the return type is partly returned in FP + registers to avoid creating problematic paradoxical subregs. + Note that we need to cater to historical 32-bit architectures + that incorrectly use the mode to select the return mechanism. */ + else if (INTEGRAL_MODE_P (TYPE_MODE (gnu_cico_return_type)) + && !gnu_cico_only_integral_type + && BITS_PER_WORD >= 64 + && !targetm.calls.return_in_memory (gnu_cico_return_type, + NULL_TREE)) + SET_TYPE_MODE (gnu_cico_return_type, BLKmode); + if (debug_info_p) rest_of_record_type_compilation (gnu_cico_return_type); } diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 4abd4d5..d68b373 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -54,9 +54,6 @@ #include "ada-tree.h" #include "gigi.h" -/* This symbol needs to be defined for the front-end. */ -void *callgraph_info_file = NULL; - /* Command-line argc and argv. These variables are global since they are imported in back_end.adb. */ unsigned int save_argc; diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 61e05d5..ef16a08 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -8421,7 +8421,7 @@ gnat_to_gnu (Node_Id gnat_node) gnat_temp = Entity (Name (gnat_node)); if (Freeze_Node (gnat_temp)) { - tree gnu_address = gnat_to_gnu (Expression (gnat_node)); + tree gnu_address = gnat_to_gnu (Expression (gnat_node)), gnu_temp; /* Get the value to use as the address and save it as the equivalent for the object; when it is frozen, gnat_to_gnu_entity will do the @@ -8431,7 +8431,7 @@ gnat_to_gnu (Node_Id gnat_node) of the object is limited and it is initialized with the result of a function call. */ if (Is_Subprogram (gnat_temp)) - gnu_result = gnu_address; + gnu_temp = gnu_address; else { tree gnu_type = gnat_to_gnu_type (Etype (gnat_temp)); @@ -8440,11 +8440,11 @@ gnat_to_gnu (Node_Id gnat_node) gnu_type = build_reference_type_for_mode (gnu_type, ptr_mode, true); gnu_address = convert (gnu_type, gnu_address); - gnu_result + gnu_temp = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_address); } - save_gnu_tree (gnat_temp, gnu_result, true); + save_gnu_tree (gnat_temp, gnu_temp, true); } break; @@ -11287,11 +11287,12 @@ maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk) const Entity_Id gnat_controlling_type = get_controlling_type (gnat_target); const Entity_Id gnat_interface_type = get_controlling_type (gnat_thunk); + /* We must have an interface type at this point. */ + gcc_assert (Is_Interface (gnat_interface_type)); + /* Now compute whether the former covers the latter. */ const Entity_Id gnat_interface_tag - = Is_Interface (gnat_interface_type) - ? Find_Interface_Tag (gnat_controlling_type, gnat_interface_type) - : Empty; + = Find_Interface_Tag (gnat_controlling_type, gnat_interface_type); tree gnu_interface_tag = Present (gnat_interface_tag) ? gnat_to_gnu_field_decl (gnat_interface_tag) diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index e14645a..fa98a5a 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -288,7 +288,6 @@ static tree split_plus (tree, tree *); static tree float_type_for_precision (int, machine_mode); static tree convert_to_fat_pointer (tree, tree); static unsigned int scale_by_factor_of (tree, unsigned int); -static bool potential_alignment_gap (tree, tree, tree); /* Linked list used as a queue to defer the initialization of the DECL_CONTEXT of ..._DECL nodes and of the TYPE_CONTEXT of ..._TYPE nodes. */ @@ -2171,7 +2170,6 @@ rest_of_record_type_compilation (tree record_type) ? UNION_TYPE : TREE_CODE (record_type)); tree orig_name = TYPE_IDENTIFIER (record_type), new_name; tree last_pos = bitsize_zero_node; - tree old_field, prev_old_field = NULL_TREE; new_name = concat_name (orig_name, TREE_CODE (record_type) == QUAL_UNION_TYPE @@ -2189,7 +2187,8 @@ rest_of_record_type_compilation (tree record_type) /* Now scan all the fields, replacing each field with a new field corresponding to the new encoding. */ - for (old_field = TYPE_FIELDS (record_type); old_field; + for (tree old_field = TYPE_FIELDS (record_type); + old_field; old_field = DECL_CHAIN (old_field)) { tree field_type = TREE_TYPE (old_field); @@ -2213,9 +2212,10 @@ rest_of_record_type_compilation (tree record_type) else pos = compute_related_constant (curpos, last_pos); - if (!pos - && TREE_CODE (curpos) == MULT_EXPR - && tree_fits_uhwi_p (TREE_OPERAND (curpos, 1))) + if (pos) + ; + else if (TREE_CODE (curpos) == MULT_EXPR + && tree_fits_uhwi_p (TREE_OPERAND (curpos, 1))) { tree offset = TREE_OPERAND (curpos, 0); align = tree_to_uhwi (TREE_OPERAND (curpos, 1)); @@ -2223,8 +2223,7 @@ rest_of_record_type_compilation (tree record_type) last_pos = round_up (last_pos, align); pos = compute_related_constant (curpos, last_pos); } - else if (!pos - && TREE_CODE (curpos) == PLUS_EXPR + else if (TREE_CODE (curpos) == PLUS_EXPR && tree_fits_uhwi_p (TREE_OPERAND (curpos, 1)) && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR && tree_fits_uhwi_p @@ -2240,20 +2239,13 @@ rest_of_record_type_compilation (tree record_type) last_pos = round_up (last_pos, align); pos = compute_related_constant (curpos, last_pos); } - else if (potential_alignment_gap (prev_old_field, old_field, pos)) + else { - align = TYPE_ALIGN (field_type); + align = DECL_ALIGN (old_field); last_pos = round_up (last_pos, align); pos = compute_related_constant (curpos, last_pos); } - /* If we can't compute a position, set it to zero. - - ??? We really should abort here, but it's too much work - to get this correct for all cases. */ - if (!pos) - pos = bitsize_zero_node; - /* See if this type is variable-sized and make a pointer type and indicate the indirection if so. Beware that the debug back-end may adjust the position computed above according @@ -2261,15 +2253,26 @@ rest_of_record_type_compilation (tree record_type) in this case, if we don't preventively counter that. */ if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST) { - field_type = build_pointer_type (field_type); - if (align != 0 && TYPE_ALIGN (field_type) > align) + field_type = copy_type (build_pointer_type (field_type)); + SET_TYPE_ALIGN (field_type, BITS_PER_UNIT); + var = true; + + /* ??? Kludge to work around a bug in Workbench's debugger. */ + if (align == 0) { - field_type = copy_type (field_type); - SET_TYPE_ALIGN (field_type, align); + align = DECL_ALIGN (old_field); + last_pos = round_up (last_pos, align); + pos = compute_related_constant (curpos, last_pos); } - var = true; } + /* If we can't compute a position, set it to zero. + + ??? We really should abort here, but it's too much work + to get this correct for all cases. */ + if (!pos) + pos = bitsize_zero_node; + /* Make a new field name, if necessary. */ if (var || align != 0) { @@ -2287,6 +2290,16 @@ rest_of_record_type_compilation (tree record_type) new_field = create_field_decl (field_name, field_type, new_record_type, DECL_SIZE (old_field), pos, 0, 0); + /* The specified position is not the actual position of the field + but the gap with the previous field, so the computation of the + bit-field status may be incorrect. We adjust it manually to + avoid generating useless attributes for the field in DWARF. */ + if (DECL_SIZE (old_field) == TYPE_SIZE (field_type) + && value_factor_p (pos, BITS_PER_UNIT)) + { + DECL_BIT_FIELD (new_field) = 0; + DECL_BIT_FIELD_TYPE (new_field) = NULL_TREE; + } DECL_CHAIN (new_field) = TYPE_FIELDS (new_record_type); TYPE_FIELDS (new_record_type) = new_field; @@ -2300,7 +2313,6 @@ rest_of_record_type_compilation (tree record_type) == QUAL_UNION_TYPE) ? bitsize_zero_node : DECL_SIZE (old_field)); - prev_old_field = old_field; } TYPE_FIELDS (new_record_type) = nreverse (TYPE_FIELDS (new_record_type)); @@ -2349,19 +2361,27 @@ merge_sizes (tree last_size, tree first_bit, tree size, bool special, bool max) return new_size; } +/* Convert the size expression EXPR to TYPE and fold the result. */ + +static tree +fold_convert_size (tree type, tree expr) +{ + /* We assume that size expressions do not wrap around. */ + if (TREE_CODE (expr) == MULT_EXPR || TREE_CODE (expr) == PLUS_EXPR) + return size_binop (TREE_CODE (expr), + fold_convert_size (type, TREE_OPERAND (expr, 0)), + fold_convert_size (type, TREE_OPERAND (expr, 1))); + + return fold_convert (type, expr); +} + /* Return the bit position of FIELD, in bits from the start of the record, and fold it as much as possible. This is a tree of type bitsizetype. */ static tree fold_bit_position (const_tree field) { - tree offset = DECL_FIELD_OFFSET (field); - if (TREE_CODE (offset) == MULT_EXPR || TREE_CODE (offset) == PLUS_EXPR) - offset = size_binop (TREE_CODE (offset), - fold_convert (bitsizetype, TREE_OPERAND (offset, 0)), - fold_convert (bitsizetype, TREE_OPERAND (offset, 1))); - else - offset = fold_convert (bitsizetype, offset); + tree offset = fold_convert_size (bitsizetype, DECL_FIELD_OFFSET (field)); return size_binop (PLUS_EXPR, DECL_FIELD_BIT_OFFSET (field), size_binop (MULT_EXPR, offset, bitsize_unit_node)); } @@ -3252,52 +3272,6 @@ scale_by_factor_of (tree expr, unsigned int value) return factor * value; } -/* Given two consecutive field decls PREV_FIELD and CURR_FIELD, return true - unless we can prove these 2 fields are laid out in such a way that no gap - exist between the end of PREV_FIELD and the beginning of CURR_FIELD. OFFSET - is the distance in bits between the end of PREV_FIELD and the starting - position of CURR_FIELD. It is ignored if null. */ - -static bool -potential_alignment_gap (tree prev_field, tree curr_field, tree offset) -{ - /* If this is the first field of the record, there cannot be any gap */ - if (!prev_field) - return false; - - /* If the previous field is a union type, then return false: The only - time when such a field is not the last field of the record is when - there are other components at fixed positions after it (meaning there - was a rep clause for every field), in which case we don't want the - alignment constraint to override them. */ - if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE) - return false; - - /* If the distance between the end of prev_field and the beginning of - curr_field is constant, then there is a gap if the value of this - constant is not null. */ - if (offset && tree_fits_uhwi_p (offset)) - return !integer_zerop (offset); - - /* If the size and position of the previous field are constant, - then check the sum of this size and position. There will be a gap - iff it is not multiple of the current field alignment. */ - if (tree_fits_uhwi_p (DECL_SIZE (prev_field)) - && tree_fits_uhwi_p (bit_position (prev_field))) - return ((tree_to_uhwi (bit_position (prev_field)) - + tree_to_uhwi (DECL_SIZE (prev_field))) - % DECL_ALIGN (curr_field) != 0); - - /* If both the position and size of the previous field are multiples - of the current field alignment, there cannot be any gap. */ - if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field)) - && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field))) - return false; - - /* Fallback, return that there may be a potential gap */ - return true; -} - /* Return a LABEL_DECL with NAME. GNAT_NODE is used for the position of the decl. */ diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 2a4ad37..f7c2923 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , Sep 14, 2019 +GNAT Reference Manual , Dec 10, 2019 AdaCore @@ -4508,7 +4508,9 @@ At compile time, the programmer can specify the invalid value for a particular family of scalar types using the optional arguments of the pragma. The compile-time approach is intended to optimize the generated code for the -pragma, by possibly using fast operations such as @code{memset}. +pragma, by possibly using fast operations such as @code{memset}. Note that such +optimizations require using values where the bytes all have the same binary +representation. @item At bind time, the programmer has several options: @@ -4538,7 +4540,7 @@ The bind-time approach is intended to provide fast turnaround for testing with different values, without having to recompile the program. @item -At execution time, the programmer can speify the invalid values using an +At execution time, the programmer can specify the invalid values using an environment variable. See the GNAT User's Guide for details. The execution-time approach is intended to provide fast turnaround for @@ -8931,8 +8933,8 @@ pragma Volatile_Full_Access (LOCAL_NAME); This is similar in effect to pragma Volatile, except that any reference to the object is guaranteed to be done only with instructions that read or write all the bits of the object. Furthermore, if the object is of a composite type, -then any reference to a component of the object is guaranteed to read and/or -write all the bits of the object. +then any reference to a subcomponent of the object is guaranteed to read +and/or write all the bits of the object. The intention is that this be suitable for use with memory-mapped I/O devices on some machines. Note that there are two important respects in which this is @@ -8944,7 +8946,7 @@ is not to the whole object; the compiler is allowed (and generally will) access only part of the object in this case. It is not permissible to specify @code{Atomic} and @code{Volatile_Full_Access} for -the same object. +the same type or object. It is not permissible to specify @code{Volatile_Full_Access} for a composite (record or array) type or object that has at least one @code{Aliased} component. diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index a1ef122..07db41f 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 , Oct 09, 2019 +GNAT User's Guide for Native Platforms , Dec 10, 2019 AdaCore @@ -20730,8 +20730,7 @@ for more information. @section Profiling -This section describes how to use the the @code{gprof} profiler tool on Ada -programs. +This section describes how to use the @code{gprof} profiler tool on Ada programs. @geindex gprof diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 7048ab4..6bff383 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -609,7 +609,22 @@ package body Impunit is ("a-cforse", F), -- Ada.Containers.Formal_Ordered_Sets ("a-cforma", F), -- Ada.Containers.Formal_Ordered_Maps ("a-cfhase", F), -- Ada.Containers.Formal_Hashed_Sets - ("a-cfhama", F)); -- Ada.Containers.Formal_Hashed_Maps + ("a-cfhama", F), -- Ada.Containers.Formal_Hashed_Maps + ("a-cvgpso", F) -- Ada.Containers.Vectors.Generic_Parallel_Sorting from + ); -- GNATCOLL.OMP + + -------------------- + -- Ada 202X Units -- + -------------------- + + -- The following units should be used only in Ada 202X mode + + Non_Imp_File_Names_2X : constant File_List := ( + 0 => ("a-stteou", T) -- Ada.Strings.Text_Output + -- ???We use named notation, because there is only one of these so far. + -- When we add more, we should switch to positional notation, and erase + -- the "0 =>". + ); ----------------------- -- Alternative Units -- @@ -731,6 +746,14 @@ package body Impunit is end if; end loop; + -- See if name is in 202X list + + for J in Non_Imp_File_Names_2X'Range loop + if Buffer = Non_Imp_File_Names_2X (J).Fname then + return Ada_202X_Unit; + end if; + end loop; + -- Only remaining special possibilities are children of System.RPC and -- System.Garlic and special files of the form System.Aux... diff --git a/gcc/ada/impunit.ads b/gcc/ada/impunit.ads index 466cb86..7e6ea61 100644 --- a/gcc/ada/impunit.ads +++ b/gcc/ada/impunit.ads @@ -45,19 +45,13 @@ package Impunit is -- This is not a predefined unit, so no checks are needed Ada_95_Unit, - -- This unit is defined in the Ada 95 RM, and can be freely with'ed in - -- both Ada 95 mode and Ada 05 mode. Note that in Ada 83 mode, no child - -- units are allowed, so you can't even name such a unit. - Ada_2005_Unit, - -- This unit is defined in the Ada 2005 RM. Withing this unit from an - -- Ada 95 mode program will generate a warning (again, strictly speaking - -- this should be an error, but that seems over-strenuous). - - Ada_2012_Unit); - -- This unit is defined in the Ada 2012 RM. Withing this unit from an - -- Ada 95 or 2005 mode program will generate a warning (again, strictly - -- speaking this should be an error, but that seems over-strenuous). + Ada_2012_Unit, + Ada_202X_Unit); + -- This unit is defined in the Ada RM of the given year. This is used to + -- give a warning when withing a unit from a wrong mode (e.g. withing an + -- Ada_2012_Unit when compiling with -gnat95). Note that in Ada 83 mode, + -- no child units are allowed, so you can't even name such a unit. function Get_Kind_Of_Unit (U : Unit_Number_Type) return Kind_Of_Unit; -- Given the unit number of a unit, this function determines the type diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 0d80ab2..c32c0c9 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -256,7 +256,7 @@ package body Inline is -- the call is in the main compilation unit, Caller is Empty. procedure Add_Inlined_Instance (E : Entity_Id); - -- Add instance E to the list of of inlined instances for the unit + -- Add instance E to the list of inlined instances for the unit procedure Add_Inlined_Subprogram (E : Entity_Id); -- Add subprogram E to the list of inlined subprograms for the unit diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index f8e9099..4fc502b 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -764,9 +764,9 @@ package body Layout is end if; -- Check components. If any component requires a higher alignment, - -- then we set that higher alignment in any case. Don't do this if - -- we have Optimize_Alignment set to Space. Note that that covers - -- the case of packed records, where we already set alignment to 1. + -- then we set that higher alignment in any case. Don't do this if we + -- have Optimize_Alignment set to Space. Note that covers the case of + -- packed records, where we already set alignment to 1. if not Optimize_Alignment_Space (E) then declare diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 7665f86..f20a18f 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -476,6 +476,8 @@ package Lib is function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type; -- Get value of named field from given units table entry + -- WARNING: There is a matching C declaration of a few subprograms in fe.h + procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id); procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id); procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True); @@ -617,6 +619,8 @@ package Lib is -- the special case check to that routine. This avoids some difficulties -- with some other calls that malfunctioned with the odd return of True. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean; -- Same function as above, but argument is a source pointer rather -- than a node. diff --git a/gcc/ada/libgnarl/a-dispat.ads b/gcc/ada/libgnarl/a-dispat.ads index b4e4d03..8e4dfe6 100644 --- a/gcc/ada/libgnarl/a-dispat.ads +++ b/gcc/ada/libgnarl/a-dispat.ads @@ -13,11 +13,13 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Task_Identification; + package Ada.Dispatching is pragma Preelaborate (Dispatching); procedure Yield with - Global => null; + Global => (In_Out => Ada.Task_Identification.Tasking_State); Dispatching_Policy_Error : exception; end Ada.Dispatching; diff --git a/gcc/ada/libgnat/a-calfor.adb b/gcc/ada/libgnat/a-calfor.adb index 0fbb1ab..5cc151d 100644 --- a/gcc/ada/libgnat/a-calfor.adb +++ b/gcc/ada/libgnat/a-calfor.adb @@ -52,6 +52,15 @@ package body Ada.Calendar.Formatting is -- such as 1983-*1-j3 u5:n7:k9 which should be 1983-01-03 05:07:09. Raise -- Constraint_Error if there is a mismatch. + procedure Split_Duration + (Seconds : Duration; + Hour : out Natural; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration); + -- Version of Split that allows durations < 100 hours. + -- Will raise Time_Error if Seconds >= 100 hours. + ---------------- -- Check_Char -- ---------------- @@ -140,7 +149,7 @@ package body Ada.Calendar.Formatting is Include_Time_Fraction : Boolean := False) return String is To_Char : constant array (0 .. 9) of Character := "0123456789"; - Hour : Hour_Number; + Hour : Natural; Minute : Minute_Number; Second : Second_Number; Sub_Second : Duration; @@ -155,7 +164,7 @@ package body Ada.Calendar.Formatting is Result : String := "-00:00:00.00"; begin - Split (abs (Elapsed_Time), Hour, Minute, Second, Sub_Second); + Split_Duration (abs Elapsed_Time, Hour, Minute, Second, Sub_Second); -- Hour processing, positions 2 and 3 @@ -361,6 +370,34 @@ package body Ada.Calendar.Formatting is Sub_Second; end Seconds_Of; + -------------------- + -- Split_Duration -- + -------------------- + + procedure Split_Duration + (Seconds : Duration; + Hour : out Natural; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration) + is + Secs : Natural; + begin + -- Check that Seconds is below 100 hours + + if Seconds >= 3600.0 * 100.0 then + raise Time_Error; + end if; + + Secs := (if Seconds = 0.0 then 0 else Natural (Seconds - 0.5)); + + Sub_Second := Second_Duration (Seconds - Duration (Secs)); + Hour := Natural (Secs / 3_600); + Secs := Secs mod 3_600; + Minute := Minute_Number (Secs / 60); + Second := Second_Number (Secs mod 60); + end Split_Duration; + ----------- -- Split -- ----------- @@ -372,8 +409,7 @@ package body Ada.Calendar.Formatting is Second : out Second_Number; Sub_Second : out Second_Duration) is - Secs : Natural; - + Unchecked_Hour : Natural; begin -- Validity checks @@ -381,23 +417,13 @@ package body Ada.Calendar.Formatting is raise Constraint_Error; end if; - Secs := (if Seconds = 0.0 then 0 else Natural (Seconds - 0.5)); - - Sub_Second := Second_Duration (Seconds - Day_Duration (Secs)); - Hour := Hour_Number (Secs / 3_600); - Secs := Secs mod 3_600; - Minute := Minute_Number (Secs / 60); - Second := Second_Number (Secs mod 60); - - -- Validity checks + Split_Duration (Seconds, Unchecked_Hour, Minute, Second, Sub_Second); - if not Hour'Valid - or else not Minute'Valid - or else not Second'Valid - or else not Sub_Second'Valid - then + if Unchecked_Hour > Hour_Number'Last then raise Time_Error; end if; + + Hour := Unchecked_Hour; end Split; ----------- diff --git a/gcc/ada/libgnat/a-calfor.ads b/gcc/ada/libgnat/a-calfor.ads index 78603ea..60a586e 100644 --- a/gcc/ada/libgnat/a-calfor.ads +++ b/gcc/ada/libgnat/a-calfor.ads @@ -204,7 +204,7 @@ package Ada.Calendar.Formatting is -- to the string as a point followed by a 2-digit value. If Elapsed_Time < -- 0.0, the result is Image (abs Elapsed_Time, Include_Time_Fraction) -- prefixed with a minus sign. If abs Elapsed_Time represents 100 hours or - -- more, the result is implementation-defined. + -- more, Time_Error is raised. function Value (Elapsed_Time : String) return Duration; -- Returns a Duration value for the image given as Elapsed_Time. diff --git a/gcc/ada/libgnat/a-cfinve.adb b/gcc/ada/libgnat/a-cfinve.adb index a187128..b5c318b 100644 --- a/gcc/ada/libgnat/a-cfinve.adb +++ b/gcc/ada/libgnat/a-cfinve.adb @@ -458,7 +458,7 @@ is Index : Index_Type := Index_Type'First) return Extended_Index is K : Count_Type; - Last : constant Index_Type := Last_Index (Container); + Last : constant Extended_Index := Last_Index (Container); begin K := Capacity_Range (Int (Index) - Int (No_Index)); diff --git a/gcc/ada/libgnat/a-cofove.adb b/gcc/ada/libgnat/a-cofove.adb index 3a10d32..1240a50 100644 --- a/gcc/ada/libgnat/a-cofove.adb +++ b/gcc/ada/libgnat/a-cofove.adb @@ -379,7 +379,7 @@ is Index : Index_Type := Index_Type'First) return Extended_Index is K : Count_Type; - Last : constant Index_Type := Last_Index (Container); + Last : constant Extended_Index := Last_Index (Container); begin K := Capacity_Range (Int (Index) - Int (No_Index)); diff --git a/gcc/ada/libgnat/g-altive.ads b/gcc/ada/libgnat/g-altive.ads index 686ee85..a77a60d 100644 --- a/gcc/ada/libgnat/g-altive.ads +++ b/gcc/ada/libgnat/g-altive.ads @@ -494,7 +494,7 @@ end GNAT.Altivec; -- The central idea for the Ada bindings is to leverage on the existing GCC -- architecture, with the introduction of a Low_Level_Vectors abstraction. --- This abstaction acts as a representative of the vector-types and builtins +-- This abstraction acts as a representative of the vector-types and builtins -- compiler interface for either the Hard or the Soft case. -- For the Hard binding, Low_Level_Vectors exposes data types with a GCC diff --git a/gcc/ada/libgnat/g-comlin.adb b/gcc/ada/libgnat/g-comlin.adb index e3fac5b..ec057a9 100644 --- a/gcc/ada/libgnat/g-comlin.adb +++ b/gcc/ada/libgnat/g-comlin.adb @@ -385,10 +385,25 @@ package body GNAT.Command_Line is ------------------ function Get_Argument - (Do_Expansion : Boolean := False; + (Do_Expansion : Boolean := False; Parser : Opt_Parser := Command_Line_Parser) return String is + End_Of_Args : Boolean; begin + return Get_Argument (Do_Expansion, Parser, End_Of_Args); + end Get_Argument; + + ------------------ + -- Get_Argument -- + ------------------ + + function Get_Argument + (Do_Expansion : Boolean := False; + Parser : Opt_Parser := Command_Line_Parser; + End_Of_Arguments : out Boolean) return String is + begin + End_Of_Arguments := False; + if Parser.In_Expansion then declare S : constant String := Expansion (Parser.Expansion_It); @@ -415,6 +430,7 @@ package body GNAT.Command_Line is end loop; else + End_Of_Arguments := True; return String'(1 .. 0 => ' '); end if; @@ -436,9 +452,11 @@ package body GNAT.Command_Line is end loop; if Parser.Current_Argument > Parser.Arg_Count then + End_Of_Arguments := True; return String'(1 .. 0 => ' '); + elsif Parser.Section (Parser.Current_Argument) = 0 then - return Get_Argument (Do_Expansion); + return Get_Argument (Do_Expansion, Parser, End_Of_Arguments); end if; Parser.Current_Argument := Parser.Current_Argument + 1; @@ -451,13 +469,10 @@ package body GNAT.Command_Line is Argument (Parser, Parser.Current_Argument - 1); begin for Index in Arg'Range loop - if Arg (Index) = '*' - or else Arg (Index) = '?' - or else Arg (Index) = '[' - then + if Arg (Index) in '*' | '?' | '[' then Parser.In_Expansion := True; Start_Expansion (Parser.Expansion_It, Arg); - return Get_Argument (Do_Expansion, Parser); + return Get_Argument (Do_Expansion, Parser, End_Of_Arguments); end if; end loop; end; diff --git a/gcc/ada/libgnat/g-comlin.ads b/gcc/ada/libgnat/g-comlin.ads index 188b035..34feee7 100644 --- a/gcc/ada/libgnat/g-comlin.ads +++ b/gcc/ada/libgnat/g-comlin.ads @@ -462,8 +462,9 @@ package GNAT.Command_Line is function Get_Argument (Do_Expansion : Boolean := False; Parser : Opt_Parser := Command_Line_Parser) return String; - -- Returns the next element on the command line that is not a switch. This - -- function should not be called before Getopt has returned ASCII.NUL. + -- Returns the next element on the command line that is not a switch. This + -- function should be called either after Getopt has returned ASCII.NUL or + -- after Getopt procedure call. -- -- If Do_Expansion is True, then the parameter on the command line will -- be considered as a filename with wildcards, and will be expanded. The @@ -472,6 +473,16 @@ package GNAT.Command_Line is -- When there are no more arguments on the command line, this function -- returns an empty string. + function Get_Argument + (Do_Expansion : Boolean := False; + Parser : Opt_Parser := Command_Line_Parser; + End_Of_Arguments : out Boolean) return String; + -- The same as above but able to distinguish empty element in argument list + -- from end of arguments. + -- End_Of_Arguments is True if the end of the command line has been reached + -- (i.e. all available arguments have been returned by previous calls to + -- Get_Argument). + function Parameter (Parser : Opt_Parser := Command_Line_Parser) return String; -- Returns parameter associated with the last switch returned by Getopt. diff --git a/gcc/ada/locales.c b/gcc/ada/locales.c index 2bf9003..9372bdb 100644 --- a/gcc/ada/locales.c +++ b/gcc/ada/locales.c @@ -529,7 +529,7 @@ static char* iso_3166[] = "UM", "United States Minor Outlying Islands", "US", "United States", "US", "United States of America", - "US", "United-States" + "US", "United-States", "UY", "Uruguay", "UZ", "Uzbekistan", diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index bdd3dad..c00fdef 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -38,7 +38,6 @@ package Namet is -- WARNING: There is a C version of this package. Any changes to this -- source file must be properly reflected in the C header file namet.h --- which is created manually from namet.ads and namet.adb. -- This package contains routines for handling the names table. The table -- is used to store character strings for identifiers and operator symbols, diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h index dfd93bb..d6011fa 100644 --- a/gcc/ada/namet.h +++ b/gcc/ada/namet.h @@ -23,9 +23,10 @@ * * ****************************************************************************/ -/* This is the C file that corresponds to the Ada package specification - Namet. It was created manually from files namet.ads and namet.adb. - Subprograms from Exp_Dbug and Sinput are also made accessible here. */ +/* This is the C header that corresponds to the Ada package specification for + Namet. It also contains the implementation of inlined functions from the + package body for Namet. It was created manually from namet.ads and + namet.adb and must be kept synchronized with changes in these files. */ #ifdef __cplusplus extern "C" { @@ -85,43 +86,6 @@ Get_Name_String (Name_Id Id) #define Name_Equals namet__name_equals extern Boolean Name_Equals (Name_Id, Name_Id); -/* The following routines and variables are not part of Namet, but we - include the header here since it seems the best place for it. */ - -#define Get_Encoded_Type_Name exp_dbug__get_encoded_type_name -extern Boolean Get_Encoded_Type_Name (Entity_Id); -#define Get_Variant_Encoding exp_dbug__get_variant_encoding -extern void Get_Variant_Encoding (Entity_Id); - -#define Spec_Context_List exp_dbug__spec_context_list -#define Body_Context_List exp_dbug__body_context_list -extern char *Spec_Context_List, *Body_Context_List; -#define Spec_Filename exp_dbug__spec_filename -#define Body_Filename exp_dbug__body_filename -extern char *Spec_Filename, *Body_Filename; - -/* Here are some functions in sinput.adb we call from trans.c. */ - -typedef Nat Source_File_Index; -typedef Int Logical_Line_Number; -typedef Int Column_Number; - -#define Debug_Source_Name sinput__debug_source_name -#define Full_Debug_Name sinput__full_debug_name -#define Reference_Name sinput__reference_name -#define Get_Source_File_Index sinput__get_source_file_index -#define Get_Logical_Line_Number sinput__get_logical_line_number -#define Get_Column_Number sinput__get_column_number -#define Instantiation sinput__instantiation - -extern File_Name_Type Debug_Source_Name (Source_File_Index); -extern File_Name_Type Full_Debug_Name (Source_File_Index); -extern File_Name_Type Reference_Name (Source_File_Index); -extern Source_File_Index Get_Source_File_Index (Source_Ptr); -extern Logical_Line_Number Get_Logical_Line_Number (Source_Ptr); -extern Column_Number Get_Column_Number (Source_Ptr); -extern Source_Ptr Instantiation (Source_File_Index); - #ifdef __cplusplus } #endif diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index 6aec482..1c6ae2c 100644 --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.ads @@ -35,6 +35,9 @@ -- package Elists which provides another form of lists that are not threaded -- through the nodes (and therefore allow nodes to be on multiple lists). +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file nlists.h + with System; with Types; use Types; diff --git a/gcc/ada/nlists.h b/gcc/ada/nlists.h index 9475561..b678bab 100644 --- a/gcc/ada/nlists.h +++ b/gcc/ada/nlists.h @@ -23,9 +23,9 @@ * * ****************************************************************************/ -/* This is the C header corresponding to the Ada package specification for - Nlists. It also contains the implementations of inlined functions from - the package body for Nlists. It was generated manually from nlists.ads and +/* This is the C header that corresponds to the Ada package specification for + Nlists. It also contains the implementation of inlined functions from the + package body for Nlists. It was created manually from nlists.ads and nlists.adb and must be kept synchronized with changes in these files. Note that only routines for reading the tree are included, since the diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 1f068dc..fcfafc4 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -273,6 +273,8 @@ package Opt is -- switches -gnatN or -gnatd.z are used. See circuitry in gnat1drv for the -- exact conditions for setting this switch. + -- WARNING: There is a matching C declaration of this variable in fe.h + Bind_Alternate_Main_Name : Boolean := False; -- GNATBIND -- True if main should be called Alternate_Main_Name.all. @@ -458,6 +460,8 @@ package Opt is -- of the original source code. Causes debugging information to be -- written with respect to the generated code file that is written. + -- WARNING: There is a matching C declaration of this variable in fe.h + Default_Pool : Node_Id := Empty; -- GNAT -- Used to record the storage pool name (or null literal) that is the @@ -595,11 +599,15 @@ package Opt is -- associated with exception messages (in particular range and index -- checks). + -- WARNING: There is a matching C declaration of this variable in fe.h + Exception_Locations_Suppressed : Boolean := False; -- GNAT -- Set to True if a Suppress_Exception_Locations configuration pragma is -- currently active. + -- WARNING: There is a matching C declaration of this variable in fe.h + type Exception_Mechanism_Type is -- Determines the kind of mechanism used to handle exceptions -- @@ -630,6 +638,8 @@ package Opt is -- (Frontend_Exceptions + ZCX_By_Default). The C convention is there to -- allow access by gigi. + -- WARNING: There is a matching C declaration of this variable in fe.h + function Back_End_Exceptions return Boolean; function Front_End_Exceptions return Boolean; function ZCX_Exceptions return Boolean; @@ -637,6 +647,8 @@ package Opt is -- GNAT -- Various properties of the active Exception_Mechanism + -- WARNING: There is a matching C declaration of these subprograms in fe.h + Exception_Tracebacks : Boolean := False; -- GNATBIND -- Set to True to store tracebacks in exception occurrences (-Ea or -E) @@ -781,6 +793,8 @@ package Opt is -- True when switch -fdump-scos is used. When True, a table of instances is -- included in SCOs. + -- WARNING: There is a matching C declaration of this variable in fe.h + Generating_Code : Boolean := False; -- GNAT -- True if the frontend finished its work and has called the backend to @@ -1008,6 +1022,8 @@ package Opt is -- 3 = like 2, but variable fields are decoded symbolically -- 4 = like 3, but list rep info for relevant compiler-generated types + -- WARNING: There is a matching C declaration of this variable in fe.h + List_Representation_Info_To_File : Boolean := False; -- GNAT -- Set true by -gnatRs switch. Causes information from -gnatR[1-4]m to be @@ -1209,6 +1225,8 @@ package Opt is -- GNAT -- Set True if pragma No_Strict_Aliasing with no parameters encountered. + -- WARNING: There is a matching C declaration of this variable in fe.h + No_Tagged_Streams : Node_Id := Empty; -- GNAT -- If a pragma No_Tagged_Streams is active for the current scope, this @@ -1541,6 +1559,8 @@ package Opt is -- GNAT -- Set to True if -gnatp (suppress all checks) switch present. + -- WARNING: There is a matching C declaration of this variable in fe.h + Suppress_Options : Suppress_Record; -- GNAT -- Indicates outer level setting of check suppression. This initializes @@ -1747,6 +1767,12 @@ package Opt is -- including warnings on Ada 2012 obsolescent features used in Ada 2012 -- mode. Modified by use of -gnatwy/Y. + Warn_On_Ada_202X_Compatibility : Boolean := True; + -- GNAT + -- Set to True to generate all warnings on Ada 202X compatibility issues, + -- including warnings on Ada 202X obsolescent features used in Ada 202X + -- mode. ???There is no warning switch for this yet. + Warn_On_All_Unread_Out_Parameters : Boolean := False; -- GNAT -- Set to True to generate warnings in all cases where a variable is @@ -2293,6 +2319,8 @@ package Opt is -- GNAT -- True if compiling in GNAT system mode (-gnatg switch) + -- WARNING: There is a matching C declaration of this variable in fe.h + GNAT_Mode_Config : Boolean := False; -- GNAT -- True if -gnatg switch is present. GNAT_Mode may be temporary set to diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index c15547d..1ba8af1 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -889,7 +889,7 @@ get_call_site_action_for (_Unwind_Ptr ip, argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated occurrence, return true if the latter matches the former, that is, if PROPAGATED_EXCEPTION is caught by the handling code controlled by CHOICE. - This takes care of the special Non_Ada_Error case on VMS. */ +*/ #define Is_Handled_By_Others __gnat_is_handled_by_others #define Language_For __gnat_language_for @@ -906,11 +906,6 @@ extern Exception_Id EID_For (_GNAT_Exception * e); #define Foreign_Exception system__exceptions__foreign_exception extern struct Exception_Data Foreign_Exception; -#ifdef VMS -#define Non_Ada_Error system__aux_dec__non_ada_error -extern struct Exception_Data Non_Ada_Error; -#endif - /* Return true iff the exception class of EXCEPT is EC. */ static int @@ -951,23 +946,6 @@ is_handled_by (_Unwind_Ptr choice, _GNAT_Exception *propagated_exception) if (choice == E || (choice == GNAT_OTHERS && Is_Handled_By_Others (E))) return handler; -#ifdef VMS - /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we - may have different exception data pointers that should match for the - same condition code, if both an export and an import have been - registered. The import code for both the choice and the propagated - occurrence are expected to have been masked off regarding severity - bits already (at registration time for the former and from within the - low level exception vector for the latter). */ - if ((Language_For (E) == 'V' - && choice != GNAT_OTHERS - && ((Language_For (choice) == 'V' - && Foreign_Data_For (choice) != 0 - && Foreign_Data_For (choice) == Foreign_Data_For (E)) - || choice == (_Unwind_Ptr)&Non_Ada_Error))) - return handler; -#endif - /* Otherwise, it doesn't match an Ada choice. */ return nothing; } @@ -1271,36 +1249,8 @@ personality_body (_Unwind_Action uw_phases, } #ifndef __ARM_EABI_UNWINDER__ -/* Major tweak for ia64-vms : the CHF propagation phase calls this personality - routine with sigargs/mechargs arguments and has very specific expectations - on possible return values. - - We handle this with a number of specific tricks: - - 1. We tweak the personality routine prototype to have the "version" and - "phases" two first arguments be void * instead of int and _Unwind_Action - as nominally expected in the GCC context. - - This allows us to access the full range of bits passed in every case and - has no impact on the callers side since each argument remains assigned - the same single 64bit slot. - - 2. We retrieve the corresponding int and _Unwind_Action values within the - routine for regular use with truncating conversions. This is a noop when - called from the libgcc unwinder. - - 3. We assume we're called by the VMS CHF when unexpected bits are set in - both those values. The incoming arguments are then real sigargs and - mechargs pointers, which we then redirect to __gnat_handle_vms_condition - for proper processing. -*/ -#if defined (VMS) && defined (__IA64) -typedef void * version_arg_t; -typedef void * phases_arg_t; -#else typedef int version_arg_t; typedef _Unwind_Action phases_arg_t; -#endif PERSONALITY_STORAGE _Unwind_Reason_Code PERSONALITY_FUNCTION (version_arg_t, phases_arg_t, @@ -1321,28 +1271,9 @@ PERSONALITY_FUNCTION (version_arg_t version_arg, int uw_version = (int) version_arg; _Unwind_Action uw_phases = (_Unwind_Action) phases_arg; - /* Check that we're called from the ABI context we expect, with a major - possible variation on VMS for IA64. */ + /* Check that we're called from the ABI context we expect. */ if (uw_version != 1) - { -#if defined (VMS) && defined (__IA64) - - /* Assume we're called with sigargs/mechargs arguments if really - unexpected bits are set in our first two formals. Redirect to the - GNAT condition handling code in this case. */ - - extern long __gnat_handle_vms_condition (void *, void *); - - unsigned int version_unexpected_bits_mask = 0xffffff00U; - unsigned int phases_unexpected_bits_mask = 0xffffff00U; - - if ((unsigned int)uw_version & version_unexpected_bits_mask - && (unsigned int)uw_phases & phases_unexpected_bits_mask) - return __gnat_handle_vms_condition (version_arg, phases_arg); -#endif - - return _URC_FATAL_PHASE1_ERROR; - } + return _URC_FATAL_PHASE1_ERROR; return personality_body (uw_phases, uw_exception, uw_context); } @@ -1668,6 +1599,19 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame, __gnat_personality_imp); } +/* Define __gnat_personality_v0 for convenience */ + +PERSONALITY_STORAGE _Unwind_Reason_Code +__gnat_personality_v0 (version_arg_t version_arg, + phases_arg_t phases_arg, + _Unwind_Exception_Class uw_exception_class, + _Unwind_Exception *uw_exception, + _Unwind_Context *uw_context) +{ + return PERSONALITY_FUNCTION + (version_arg, phases_arg, uw_exception_class, uw_exception, uw_context); +} + #endif /* SEH */ #if !defined (__USING_SJLJ_EXCEPTIONS__) diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads index c51948e..c8eb350 100644 --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -35,6 +35,9 @@ -- compiler and in ASIS (it is used in ASIS as part of the implementation -- of the Data Decomposition Annex). +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file repinfo.h + with Types; use Types; with Uintp; use Uintp; diff --git a/gcc/ada/repinfo.h b/gcc/ada/repinfo.h index 4708618..30c3e6d 100644 --- a/gcc/ada/repinfo.h +++ b/gcc/ada/repinfo.h @@ -29,7 +29,9 @@ * * ****************************************************************************/ -/* This file corresponds to the Ada file repinfo.ads. */ +/* This is the C header that corresponds to the Ada package specification for + Repinfo. It was created manually from repinfo.ads and must be kept + synchronized with changes in this file. */ #ifdef __cplusplus extern "C" { diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index a8e9fb1..80cd012 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -307,6 +307,8 @@ package Restrict is -- elaboration routine. If elaboration code is not allowed, an error -- message is posted on the node given as argument. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Check_SPARK_05_Restriction (Msg : String; N : Node_Id; @@ -337,19 +339,27 @@ package Restrict is -- that generates a trampoline. If not allowed, an error message is posted -- on the node given as argument. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Check_No_Implicit_Heap_Alloc (N : Node_Id); -- Equivalent to Check_Restriction (No_Implicit_Heap_Allocations, N). -- Provided for easy use by back end, which has to check this restriction. - procedure Check_No_Implicit_Task_Alloc (N : Node_Id); - -- Equivalent to Check_Restriction (No_Implicit_Task_Allocations, N). - -- Provided for easy use by back end, which has to check this restriction. + -- WARNING: There is a matching C declaration of this subprogram in fe.h procedure Check_No_Implicit_Protected_Alloc (N : Node_Id); -- Equivalent to: -- Check_Restriction (No_Implicit_Protected_Object_Allocations, N) -- Provided for easy use by back end, which has to check this restriction. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + + procedure Check_No_Implicit_Task_Alloc (N : Node_Id); + -- Equivalent to Check_Restriction (No_Implicit_Task_Allocations, N). + -- Provided for easy use by back end, which has to check this restriction. + + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id); -- This routine checks if the entity E is one of the obsolescent entries -- in Ada.Characters.Handling in Ada 2005 and No_Obsolescent_Features @@ -394,6 +404,8 @@ package Restrict is -- set. In the latter case, the source may contain handlers but they either -- get converted using the local goto transformation or deleted. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function No_Exception_Propagation_Active return Boolean; -- Test to see if current restrictions settings specify that no -- exception propagation is activated. diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 2467f85..07b8069 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -36,59 +36,10 @@ package Rtsfind is -- Runtime Unit Table -- ------------------------ - -- The following type includes an enumeration entry for each runtime unit. - -- The enumeration literal represents the fully qualified name of the unit, - -- as follows: - - -- Names of the form Ada_xxx are first level children of Ada, whose name - -- is Ada.xxx. For example, the name Ada_Tags refers to package Ada.Tags. - - -- Names of the form Ada_Calendar_xxx are second level children of - -- Ada.Calendar. This is part of a temporary implementation of delays; - -- eventually, packages implementing delays will be found relative to - -- the package that declares the time type. - - -- Names of the form Ada_Interrupts_xxx are second level children of - -- Ada.Interrupts. This is needed for Ada.Interrupts.Names which is used - -- by pragma Interrupt_State. - - -- Names of the form Ada_Real_Time_xxx are second level children of - -- Ada.Real_Time. - - -- Names of the form Ada_Streams_xxx are second level children - -- of Ada.Streams. - - -- Names of the form Ada_Strings_xxx are second level children - -- of Ada.Strings. - - -- Names of the form Ada_Text_IO_xxx are second level children of - -- Ada.Text_IO. - - -- Names of the form Ada_Wide_Text_IO_xxx are second level children of - -- Ada.Wide_Text_IO. - - -- Names of the form Ada_Wide_Wide_Text_IO_xxx are second level children - -- of Ada.Wide_Wide_Text_IO. - - -- Names of the form Interfaces_xxx are first level children of - -- Interfaces. For example, the name Interfaces_Packed_Decimal refers to - -- package Interfaces.Packed_Decimal. - - -- Names of the form System_xxx are first level children of System, whose - -- name is System.xxx. For example, the name System_Str_Concat refers to - -- package System.Str_Concat. - - -- Names of the form System_Storage_Pools_xxx are second level children - -- of the package System.Storage_Pools. - - -- Names of the form System_Strings_xxx are second level children of the - -- package System.Strings. - - -- Names of the form System_Tasking_xxx are second level children of the - -- package System.Tasking. For example, System_Tasking_Stages refers to - -- the package System.Tasking.Stages. - - -- Other names stand for themselves (e.g. System for package System) + -- The following type includes an enumeration literal for each runtime + -- unit. The enumeration literal is the full expanded name of the unit + -- with "." replaced by "_". For example, the enumeration literal for + -- Ada.Interrupts.Names is Ada_Interrupts_Names -- This list can contain both subprogram and package unit names. For -- packages, the accessible entities in the package are separately listed @@ -100,13 +51,13 @@ package Rtsfind is -- seem worthwhile, since the implementation controls the set of units that -- are referenced, and this restriction is easily met. - -- IMPORTANT NOTE: the specs of packages and procedures with'ed using this - -- mechanism may not contain use clauses. This is because these subprograms - -- are compiled in the current visibility environment, and it would be too - -- much trouble to establish a clean environment for the compilation. The - -- presence of extraneous visible stuff has no effect on the compilation - -- except in the presence of use clauses (which might result in unexpected - -- ambiguities). + -- IMPORTANT NOTE: the specs of packages and procedures with'ed using + -- this mechanism must not contain use clauses. This is because these + -- subprograms are compiled in the current visibility environment, and it + -- would be too much trouble to establish a clean environment for the + -- compilation. The presence of extraneous visible stuff has no effect on + -- the compilation except in the presence of use clauses, which might + -- result in unexpected ambiguities. type RTU_Id is ( diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index b114acb..9f56297 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -28,6 +28,9 @@ -- the ALI file, and by Get_SCO/Put_SCO to read and write the text form that -- is used in the ALI file. +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file scos.h + with Namet; use Namet; with Table; with Types; use Types; @@ -48,9 +51,6 @@ package SCOs is -- Put_SCO reads the internal tables and generates text lines in the ALI -- format. - -- WARNING: There are C bindings for this package. Any changes to this - -- source file must be properly reflected in the C header file scos.h - -------------------- -- SCO ALI Format -- -------------------- diff --git a/gcc/ada/scos.h b/gcc/ada/scos.h index a385264..53f9f38 100644 --- a/gcc/ada/scos.h +++ b/gcc/ada/scos.h @@ -23,8 +23,9 @@ * * ****************************************************************************/ -/* This is the C file that corresponds to the Ada package spec SCOs. It was - created manually from the file scos.ads. */ +/* This is the C header that corresponds to the Ada package specification for + Scos. It was created manually from scos.ads and must be kept synchronized + with changes in this file. */ #ifdef __cplusplus extern "C" { diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads index 5f06b4d..1d4f348 100644 --- a/gcc/ada/sem_aggr.ads +++ b/gcc/ada/sem_aggr.ads @@ -37,4 +37,6 @@ package Sem_Aggr is function Is_Others_Aggregate (Aggr : Node_Id) return Boolean; -- Returns True is aggregate Aggr consists of a single OTHERS choice + -- WARNING: There is a matching C declaration of this subprogram in fe.h + end Sem_Aggr; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 95de2e4..e842293 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -5414,6 +5414,7 @@ package body Sem_Attr is Spec_Id := Entity (P); elsif not Legal then + Error_Attr ("prefix of % attribute must be a function", P); return; end if; @@ -7852,6 +7853,8 @@ package body Sem_Attr is -- is legal, since here this expression appears in a statically -- unevaluated position, so it does not actually raise an exception. + -- + -- T'Descriptor_Size is never static, even if T is static. if Is_Scalar_Type (P_Entity) and then (not Is_Generic_Type (P_Entity)) @@ -7865,6 +7868,7 @@ package body Sem_Attr is (No (E2) or else (Is_Static_Expression (E2) and then Is_Scalar_Type (Etype (E1)))) + and then Id /= Attribute_Descriptor_Size then Static := True; Set_Is_Static_Expression (N, True); diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 55cfefa..ee3a2b3 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -91,6 +91,8 @@ package Sem_Aux is -- subtype then it returns the subtype or type from which the subtype was -- obtained, otherwise it returns Empty. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Available_View (Ent : Entity_Id) return Entity_Id; -- Ent denotes an abstract state or a type that may come from a limited -- with clause. Return the non-limited view of Ent if there is one or Ent @@ -104,6 +106,8 @@ package Sem_Aux is -- constants from the point of view of constant folding. Empty is also -- returned for variables with no initialization expression. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Corresponding_Unsigned_Type (Typ : Entity_Id) return Entity_Id; -- Typ is a signed integer subtype. This routine returns the standard -- unsigned type with the same Esize as the implementation base type of @@ -123,6 +127,8 @@ package Sem_Aux is -- When called on a private type with unknown discriminants, the function -- always returns Empty. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id; -- Typ is a type with discriminants. Gives the first discriminant stored -- in an object of this type. In many cases, these are the same as the @@ -146,11 +152,15 @@ package Sem_Aux is -- discriminants from Gigi's standpoint, i.e. those that will be stored in -- actual objects of the type. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function First_Subtype (Typ : Entity_Id) return Entity_Id; -- Applies to all types and subtypes. For types, yields the first subtype -- of the type. For subtypes, yields the first subtype of the base type of -- the subtype. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function First_Tag_Component (Typ : Entity_Id) return Entity_Id; -- Typ must be a tagged record type. This function returns the Entity for -- the first _Tag field in the record type. @@ -317,6 +327,8 @@ package Sem_Aux is -- Ent is any entity. Returns True if Ent is a type entity where the type -- is required to be passed by reference, as defined in (RM 6.2(4-9)). + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Is_Definite_Subtype (T : Entity_Id) return Boolean; -- T is a type entity. Returns True if T is a definite subtype. -- Indefinite subtypes are unconstrained arrays, unconstrained @@ -329,6 +341,8 @@ package Sem_Aux is -- Determines if the given entity Ent is a derived type. Result is always -- false if argument is not a type. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Is_Generic_Formal (E : Entity_Id) return Boolean; -- Determine whether E is a generic formal parameter. In particular this is -- used to set the visibility of generic formals of a generic package diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index c5d10f7..ae8bca7 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2226,9 +2226,18 @@ package body Sem_Ch10 is -- If the subunit occurs within a child unit, we must restore the -- immediate visibility of any siblings that may occur in context. + -- In addition, we must reset the previous visibility of the + -- parent unit which is now on the scope stack. This is because + -- the Previous_Visibility was previously set when removing the + -- context. This is necessary to prevent the parent entity from + -- remaining visible after the subunit is compiled. This only + -- has an effect if a homonym exists in a body to be processed + -- later if inlining is enabled. if Present (Enclosing_Child) then Install_Siblings (Enclosing_Child, L); + Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility := + False; end if; Push_Scope (Scop); @@ -2657,12 +2666,8 @@ package body Sem_Ch10 is and then not Implicit_With (N) and then not Restriction_Violation then - declare - U_Kind : constant Kind_Of_Unit := - Get_Kind_Of_Unit (Get_Source_Unit (U)); - - begin - if U_Kind = Implementation_Unit then + case Get_Kind_Of_Unit (Get_Source_Unit (U)) is + when Implementation_Unit => Error_Msg_F ("& is an internal 'G'N'A'T unit?i?", Name (N)); -- Add alternative name if available, otherwise issue a @@ -2676,19 +2681,30 @@ package body Sem_Ch10 is & "version-dependent?i?", Name (N)); end if; - elsif U_Kind = Ada_2005_Unit - and then Ada_Version < Ada_2005 - and then Warn_On_Ada_2005_Compatibility - then - Error_Msg_N ("& is an Ada 2005 unit?i?", Name (N)); + when Not_Predefined_Unit | Ada_95_Unit => + null; -- no checks needed - elsif U_Kind = Ada_2012_Unit - and then Ada_Version < Ada_2012 - and then Warn_On_Ada_2012_Compatibility - then - Error_Msg_N ("& is an Ada 2012 unit?i?", Name (N)); - end if; - end; + when Ada_2005_Unit => + if Ada_Version < Ada_2005 + and then Warn_On_Ada_2005_Compatibility + then + Error_Msg_N ("& is an Ada 2005 unit?i?", Name (N)); + end if; + + when Ada_2012_Unit => + if Ada_Version < Ada_2012 + and then Warn_On_Ada_2012_Compatibility + then + Error_Msg_N ("& is an Ada 2012 unit?i?", Name (N)); + end if; + + when Ada_202X_Unit => + if Ada_Version < Ada_2020 + and then Warn_On_Ada_202X_Compatibility + then + Error_Msg_N ("& is an Ada 202X unit?i?", Name (N)); + end if; + end case; end if; end if; @@ -5327,6 +5343,20 @@ package body Sem_Ch10 is Error_Msg_N ("instantiation depends on itself", Name (With_Clause)); + elsif not Analyzed (Uname) + and then Is_Internal_Unit (Current_Sem_Unit) + and then not Is_Visible_Lib_Unit (Uname) + and then No (Scope (Uname)) + then + if Is_Predefined_Unit (Current_Sem_Unit) then + Error_Msg_N + ("predefined unit depends on itself", Name (With_Clause)); + else + Error_Msg_N + ("GNAT-defined unit depends on itself", Name (With_Clause)); + end if; + return; + elsif not Is_Visible_Lib_Unit (Uname) then -- Abandon processing in case of previous errors diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 8c3559f..6932368 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -4501,7 +4501,7 @@ package body Sem_Ch12 is -- the case of nested instances for the time being. -- When we generate a nested instance body, calling stubs for any - -- relevant subprogram will be be inserted immediately after the + -- relevant subprogram will be inserted immediately after the -- subprogram declarations, and will take precedence over the -- subsequent (original) body. (The stub and original body will be -- complete homographs, but this is permitted in an instance). @@ -5431,8 +5431,8 @@ package body Sem_Ch12 is Instantiating => True), Name => New_Occurrence_Of (Anon_Id, Loc)); - -- The generic may be a a child unit. The renaming needs an - -- identifier with the proper name. + -- The generic may be a child unit. The renaming needs an identifier + -- with the proper name. Set_Defining_Unit_Name (Specification (Unit_Renaming), Make_Defining_Identifier (Loc, Chars (Gen_Unit))); @@ -13166,6 +13166,35 @@ package body Sem_Ch12 is Abandon_Instantiation (Actual); end if; end if; + + -- Don't check Ada_Version here (for now) because AI12-0036 is + -- a binding interpretation; this decision may be reversed if + -- the situation turns out to be similar to that of the preceding + -- Is_Limited_Type test (see preceding comment). + + declare + Formal_Is_Private_Extension : constant Boolean := + Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration; + + Actual_Is_Tagged : constant Boolean := Is_Tagged_Type (Act_T); + begin + if Actual_Is_Tagged /= Formal_Is_Private_Extension then + if In_Instance then + null; + else + if Actual_Is_Tagged then + Error_Msg_NE + ("actual for & cannot be a tagged type", + Actual, Gen_T); + else + Error_Msg_NE + ("actual for & must be a tagged type", + Actual, Gen_T); + end if; + Abandon_Instantiation (Actual); + end if; + end if; + end; end Validate_Derived_Type_Instance; ---------------------------------------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 67ec0df..e266af9 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -154,6 +154,10 @@ package body Sem_Ch13 is -- that do not specify a representation characteristic are operational -- attributes. + function Is_Type_Related_Rep_Item (N : Node_Id) return Boolean; + -- Returns True for a representation clause/pragma that specifies a + -- type-related representation (as opposed to operational) aspect. + function Is_Predicate_Static (Expr : Node_Id; Nam : Name_Id) return Boolean; @@ -770,8 +774,8 @@ package body Sem_Ch13 is -- 1 .. 4 3 .. 6 1 3 -- 4 .. 7 0 .. 3 4 0 - -- The rule is that the first bit is is obtained by - -- subtracting the old ending bit from storage_unit - 1. + -- The rule is that the first bit is obtained by subtracting + -- the old ending bit from storage_unit - 1. Set_Component_Bit_Offset (Comp, (Storage_Unit_Offset * System_Storage_Unit) + @@ -3475,11 +3479,14 @@ package body Sem_Ch13 is -- 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. + -- as possible. Also we don't do this when analyzing generic + -- units since it causes spurious visibility errors in the + -- preanalysis of instantiations. if not (ASIS_Mode or GNATprove_Mode) and then (Pname = Name_Postcondition or else not Class_Present (Aspect)) + and then not Inside_A_Generic then while Nkind (Expr) = N_And_Then loop Insert_After (Aspect, @@ -3788,6 +3795,15 @@ package body Sem_Ch13 is Set_From_Aspect_Specification (Aitem); end if; + -- For an aspect that applies to a type, indicate whether it + -- appears on a partial view of the type. + + if Is_Type (E) + and then Is_Private_Type (E) + then + Set_Aspect_On_Partial_View (Aspect); + end if; + -- In the context of a compilation unit, we directly put the -- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux -- node (no delay is required here) except for aspects on a @@ -12273,6 +12289,59 @@ package body Sem_Ch13 is end if; end Is_Predicate_Static; + ------------------------------ + -- Is_Type_Related_Rep_Item -- + ------------------------------ + + function Is_Type_Related_Rep_Item (N : Node_Id) return Boolean is + begin + case Nkind (N) is + when N_Attribute_Definition_Clause => + declare + Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); + -- See AARM 13.1(8.f-8.x) list items that end in "clause" + -- ???: include any GNAT-defined attributes here? + begin + return Id = Attribute_Component_Size + or else Id = Attribute_Bit_Order + or else Id = Attribute_Storage_Pool + or else Id = Attribute_Stream_Size + or else Id = Attribute_Machine_Radix; + end; + + when N_Pragma => + case Get_Pragma_Id (N) is + -- See AARM 13.1(8.f-8.x) list items that start with "pragma" + -- ???: include any GNAT-defined pragmas here? + when Pragma_Pack + | Pragma_Import + | Pragma_Export + | Pragma_Convention + | Pragma_Atomic + | Pragma_Independent + | Pragma_Volatile + | Pragma_Atomic_Components + | Pragma_Independent_Components + | Pragma_Volatile_Components + | Pragma_Discard_Names + => + return True; + when others => + null; + end case; + + when N_Enumeration_Representation_Clause + | N_Record_Representation_Clause + => + return True; + + when others => + null; + end case; + + return False; + end Is_Type_Related_Rep_Item; + --------------------- -- Kill_Rep_Clause -- --------------------- @@ -12955,7 +13024,7 @@ package body Sem_Ch13 is end if; -- No error, but one more warning to consider. The RM (surprisingly) - -- allows this pattern: + -- allows this pattern in some cases: -- type S is ... -- primitive operations for S @@ -12964,7 +13033,7 @@ package body Sem_Ch13 is -- Meaning that calls on the primitive operations of S for values of -- type R may require possibly expensive implicit conversion operations. - -- This is not an error, but is worth a warning. + -- So even when this is not an error, it is still worth a warning. if not Relaxed_RM_Semantics and then Is_Type (T) then declare @@ -12972,26 +13041,47 @@ package body Sem_Ch13 is begin if Present (DTL) - and then Has_Primitive_Operations (Base_Type (T)) - -- For now, do not generate this warning for the case of aspect - -- specification using Ada 2012 syntax, since we get wrong - -- messages we do not understand. The whole business of derived - -- types and rep items seems a bit confused when aspects are - -- used, since the aspects are not evaluated till freeze time. + -- For now, do not generate this warning for the case of + -- aspect specification using Ada 2012 syntax, since we get + -- wrong messages we do not understand. The whole business + -- of derived types and rep items seems a bit confused when + -- aspects are used, since the aspects are not evaluated + -- till freeze time. However, AI12-0109 confirms (in an AARM + -- ramification) that inheritance in this case is required + -- to work. and then not From_Aspect_Specification (N) then - Error_Msg_Sloc := Sloc (DTL); - Error_Msg_N - ("representation item for& appears after derived type " - & "declaration#??", N); - Error_Msg_NE - ("\may result in implicit conversions for primitive " - & "operations of&??", N, T); - Error_Msg_NE - ("\to change representations when called with arguments " - & "of type&??", N, DTL); + if Is_By_Reference_Type (T) + and then not Is_Tagged_Type (T) + and then Is_Type_Related_Rep_Item (N) + and then (Ada_Version >= Ada_2012 + or else Has_Primitive_Operations (Base_Type (T))) + then + -- Treat as hard error (AI12-0109, binding interpretation). + -- Implementing a change of representation is not really + -- an option in the case of a by-reference type, so we + -- take this path for all Ada dialects if primitive + -- operations are present. + Error_Msg_Sloc := Sloc (DTL); + Error_Msg_N + ("representation item for& appears after derived type " + & "declaration#", N); + + elsif Has_Primitive_Operations (Base_Type (T)) then + Error_Msg_Sloc := Sloc (DTL); + + Error_Msg_N + ("representation item for& appears after derived type " + & "declaration#??", N); + Error_Msg_NE + ("\may result in implicit conversions for primitive " + & "operations of&??", N, T); + Error_Msg_NE + ("\to change representations when called with arguments " + & "of type&??", N, DTL); + end if; end if; end; end if; @@ -13344,9 +13434,9 @@ package body Sem_Ch13 is => -- Build predicate function specification and preanalyze -- expression after type replacement. The function - -- declaration must be analyzed in the scope of the - -- type, but the the expression can reference components - -- and discriminants of the type. + -- declaration must be analyzed in the scope of the type, + -- but the expression can reference components and + -- discriminants of the type. if No (Predicate_Function (E)) then declare @@ -13448,6 +13538,14 @@ package body Sem_Ch13 is and then Base_Type (T1) = Full_View (Base_Type (T2)) then return True; + + -- If T2 is a generic actual it is declared as a subtype, so + -- check against its base type. + + elsif Is_Generic_Actual_Type (T1) + and then Same_Representation (Base_Type (T1), T2) + then + return True; end if; -- Tagged types always have the same representation, because it is not diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b12f69b..9554c33 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9741,9 +9741,17 @@ package body Sem_Ch3 is (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type)); end if; - -- If the parent has primitive routines, set the derived type link - - if Has_Primitive_Operations (Parent_Type) then + -- If the parent has primitive routines and may have not-seen-yet aspect + -- specifications (e.g., a Pack pragma), then set the derived type link + -- in order to later diagnose "early derivation" issues. If in different + -- compilation units, then "early derivation" cannot be an issue (and we + -- don't like interunit references that go in the opposite direction of + -- semantic dependencies). + + if Has_Primitive_Operations (Parent_Type) + and then Enclosing_Comp_Unit_Node (Parent_Type) = + Enclosing_Comp_Unit_Node (Derived_Type) + then Set_Derived_Type_Link (Parent_Base, Derived_Type); end if; @@ -12971,25 +12979,33 @@ package body Sem_Ch3 is or else Is_Incomplete_Or_Private_Type (Desig_Type)) and then not Is_Constrained (Desig_Type) then - -- ??? The following code is a temporary bypass to ignore a - -- discriminant constraint on access type if it is constraining - -- the current record. Avoid creating the implicit subtype of the - -- record we are currently compiling since right now, we cannot - -- handle these. For now, just return the access type itself. + -- If this is a constrained access definition for a record + -- component, we leave the type as an unconstrained access, + -- and mark the component so that its actual type is built + -- at a point of use (e.g., an assignment statement). This + -- is handled in Sem_Util.Build_Actual_Subtype_Of_Component. if Desig_Type = Current_Scope and then No (Def_Id) then - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_N ("<<constraint is ignored on component that is " - & "access to current record", S); - + Desig_Subtype := + Create_Itype + (E_Void, Related_Nod, Scope_Id => Scope (Desig_Type)); Set_Ekind (Desig_Subtype, E_Record_Subtype); Def_Id := Entity (Subtype_Mark (S)); + -- We indicate that the component has a per-object constraint + -- for treatment at a point of use, even though the constraint + -- may be independent of discriminants of the enclosing type. + + if Nkind (Related_Nod) = N_Component_Declaration then + Set_Has_Per_Object_Constraint + (Defining_Identifier (Related_Nod)); + end if; + -- This call added to ensure that the constraint is analyzed -- (needed for a B test). Note that we still return early from - -- this procedure to avoid recursive processing. ??? + -- this procedure to avoid recursive processing. Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, For_Access => True); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 313398a..80be4d6 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1555,7 +1555,7 @@ package body Sem_Ch4 is -- there is only a limited view of it and there is nothing in -- the context of the current unit that has required a regular -- compilation of the unit containing the type. We recognize - -- this unusual case by the fact that that unit is not analyzed. + -- this unusual case by the fact that unit is not analyzed. -- Note that the call being analyzed is in a different unit from -- the function declaration, and nothing indicates that the type -- is a limited view. @@ -3249,6 +3249,7 @@ package body Sem_Ch4 is -- is already known to be compatible, and because this may be an -- indexing of a call with default parameters. + First_Form : Entity_Id; Formal : Entity_Id; Actual : Node_Id; Is_Indexed : Boolean := False; @@ -3581,8 +3582,9 @@ package body Sem_Ch4 is -- Normalize_Actuals has chained the named associations in the -- correct order of the formals. - Actual := First_Actual (N); - Formal := First_Formal (Nam); + Actual := First_Actual (N); + Formal := First_Formal (Nam); + First_Form := Formal; -- If we are analyzing a call rewritten from object notation, skip -- first actual, which may be rewritten later as an explicit @@ -3742,6 +3744,54 @@ package body Sem_Ch4 is end if; end loop; + -- Due to our current model of controlled type expansion we may + -- have resolved a user call to a non-visible controlled primitive + -- since these inherited subprograms may be generated in the current + -- scope. This is a side effect of the need for the expander to be + -- able to resolve internally generated calls. + + -- Specifically, the issue appears when predefined controlled + -- operations get called on a type extension whose parent is a + -- private extension completed with a controlled extension - see + -- below: + + -- package X is + -- type Par_Typ is tagged private; + -- private + -- type Par_Typ is new Controlled with null record; + -- end; + -- ... + -- procedure Main is + -- type Ext_Typ is new Par_Typ with null record; + -- Obj : Ext_Typ; + -- begin + -- Finalize (Obj); -- Will improperly resolve + -- end; + + -- To avoid breaking privacy, Is_Hidden gets set elsewhere on such + -- primitives, but we still need to verify that Nam is indeed a + -- controlled subprogram. So, we do that here and issue the + -- appropriate error. + + if Is_Hidden (Nam) + and then not In_Instance + and then not Comes_From_Source (Nam) + and then Comes_From_Source (N) + + -- Verify Nam is a controlled primitive + + and then Nam_In (Chars (Nam), Name_Adjust, + Name_Finalize, + Name_Initialize) + and then Ekind (Nam) = E_Procedure + and then Is_Controlled (Etype (First_Form)) + and then No (Next_Formal (First_Form)) + then + Error_Msg_Node_2 := Etype (First_Form); + Error_Msg_NE ("call to non-visible controlled primitive & on type" + & " &", N, Nam); + end if; + -- On exit, all actuals match Indicate_Name_And_Type; @@ -4812,16 +4862,15 @@ package body Sem_Ch4 is Set_Etype (N, Etype (Comp)); else - -- Component type depends on discriminants. Enter the - -- main attributes of the subtype. + -- If discriminants were present in the component + -- declaration, they have been replaced by the + -- actual values in the prefix object. declare Subt : constant Entity_Id := Defining_Identifier (Act_Decl); - begin Set_Etype (Subt, Base_Type (Etype (Comp))); - Set_Ekind (Subt, Ekind (Etype (Comp))); Set_Etype (N, Subt); end; end if; @@ -8575,7 +8624,7 @@ package body Sem_Ch4 is procedure Transform_Object_Operation (Call_Node : out Node_Id; Node_To_Replace : out Node_Id); - -- Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..) + -- Transform Obj.Operation (X, Y, ...) into Operation (Obj, X, Y ...). -- Call_Node is the resulting subprogram call, Node_To_Replace is -- either N or the parent of N, and Subprog is a reference to the -- subprogram we are trying to match. @@ -9300,7 +9349,7 @@ package body Sem_Ch4 is -- Prefix notation can also be used on operations that are not -- primitives of the type, but are declared in the same immediate -- declarative part, which can only mean the corresponding package - -- body (See RM 4.1.3 (9.2/3)). If we are in that body we extend the + -- body (see RM 4.1.3 (9.2/3)). If we are in that body we extend the -- list of primitives with body operations with the same name that -- may be candidates, so that Try_Primitive_Operations can examine -- them if no real primitive is found. @@ -9426,56 +9475,55 @@ package body Sem_Ch4 is function Extended_Primitive_Ops (T : Entity_Id) return Elist_Id is Type_Scope : constant Entity_Id := Scope (T); - - Body_Decls : List_Id; - Op_Found : Boolean; - Op : Entity_Id; - Op_List : Elist_Id; - + Op_List : Elist_Id := Primitive_Operations (T); begin - Op_List := Primitive_Operations (T); - - if Ekind (Type_Scope) = E_Package - and then In_Package_Body (Type_Scope) - and then In_Open_Scopes (Type_Scope) + if Ekind_In (Type_Scope, E_Package, E_Generic_Package) + and then ((In_Package_Body (Type_Scope) + and then In_Open_Scopes (Type_Scope)) or else In_Instance_Body) then - -- Retrieve list of declarations of package body. - - Body_Decls := - Declarations - (Unit_Declaration_Node - (Corresponding_Body - (Unit_Declaration_Node (Type_Scope)))); - - Op := Current_Entity (Subprog); - Op_Found := False; - while Present (Op) loop - if Comes_From_Source (Op) - and then Is_Overloadable (Op) - - -- Exclude overriding primitive operations of a type - -- extension declared in the package body, to prevent - -- duplicates in extended list. - - and then not Is_Primitive (Op) - and then Is_List_Member (Unit_Declaration_Node (Op)) - and then List_Containing (Unit_Declaration_Node (Op)) = - Body_Decls - then - if not Op_Found then + -- Retrieve list of declarations of package body if possible - -- Copy list of primitives so it is not affected for - -- other uses. + declare + The_Body : constant Node_Id := + Corresponding_Body (Unit_Declaration_Node (Type_Scope)); + begin + if Present (The_Body) then + declare + Body_Decls : constant List_Id := + Declarations (Unit_Declaration_Node (The_Body)); + Op_Found : Boolean := False; + Op : Entity_Id := Current_Entity (Subprog); + begin + while Present (Op) loop + if Comes_From_Source (Op) + and then Is_Overloadable (Op) + + -- Exclude overriding primitive operations of a + -- type extension declared in the package body, + -- to prevent duplicates in extended list. + + and then not Is_Primitive (Op) + and then Is_List_Member + (Unit_Declaration_Node (Op)) + and then List_Containing + (Unit_Declaration_Node (Op)) = Body_Decls + then + if not Op_Found then + -- Copy list of primitives so it is not + -- affected for other uses. - Op_List := New_Copy_Elist (Op_List); - Op_Found := True; - end if; + Op_List := New_Copy_Elist (Op_List); + Op_Found := True; + end if; - Append_Elmt (Op, Op_List); - end if; + Append_Elmt (Op, Op_List); + end if; - Op := Homonym (Op); - end loop; + Op := Homonym (Op); + end loop; + end; + end if; + end; end if; return Op_List; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 3abaa8d..a65e92c 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2343,6 +2343,27 @@ package body Sem_Ch5 is Check_Reverse_Iteration (Typ); end if; + -- For an element iteration over a slice, we must complete + -- the resolution and expansion of the slice bounds. These + -- can be arbitrary expressions, and the preanalysis that + -- was performed in preparation for the iteration may have + -- generated an itype whose bounds must be fully expanded. + -- We set the parent node to provide a proper insertion + -- point for generated actions, if any. + + if Nkind (Iter_Name) = N_Slice + and then Nkind (Discrete_Range (Iter_Name)) = N_Range + and then not Analyzed (Discrete_Range (Iter_Name)) + then + declare + Indx : constant Node_Id := + Entity (First_Index (Etype (Iter_Name))); + begin + Set_Parent (Indx, Iter_Name); + Resolve (Scalar_Range (Indx), Etype (Indx)); + end; + end if; + -- The name in the renaming declaration may be a function call. -- Indicate that it does not come from source, to suppress -- spurious warnings on renamings of parameterless functions, diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5af3b7b..386332c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3304,7 +3304,18 @@ package body Sem_Ch6 is then null; - elsif not Present (Overridden_Operation (Spec_Id)) then + -- Overridden controlled primitives may have had their + -- Overridden_Operation field cleared according to the setting of + -- the Is_Hidden flag. An issue arises, however, when analyzing + -- an instance that may have manipulated the flag during + -- expansion. As a result, we add an exception for this case. + + elsif not Present (Overridden_Operation (Spec_Id)) + and then not (Nam_In (Chars (Spec_Id), Name_Adjust, + Name_Finalize, + Name_Initialize) + and then In_Instance) + then Error_Msg_NE ("subprogram& is not overriding", Body_Spec, Spec_Id); @@ -6427,13 +6438,18 @@ package body Sem_Ch6 is -- If there is an overridden subprogram, then check that there is no -- "not overriding" indicator, and mark the subprogram as overriding. + -- This is not done if the overridden subprogram is marked as hidden, -- which can occur for the case of inherited controlled operations -- (see Derive_Subprogram), unless the inherited subprogram's parent - -- subprogram is not itself hidden. (Note: This condition could probably - -- be simplified, leaving out the testing for the specific controlled - -- cases, but it seems safer and clearer this way, and echoes similar - -- special-case tests of this kind in other places.) + -- subprogram is not itself hidden or we are within a generic instance, + -- in which case the hidden flag may have been modified for the + -- expansion of the instance. + + -- (Note: This condition could probably be simplified, leaving out the + -- testing for the specific controlled cases, but it seems safer and + -- clearer this way, and echoes similar special-case tests of this + -- kind in other places.) if Present (Overridden_Subp) and then (not Is_Hidden (Overridden_Subp) @@ -6442,7 +6458,8 @@ package body Sem_Ch6 is Name_Adjust, Name_Finalize) and then Present (Alias (Overridden_Subp)) - and then not Is_Hidden (Alias (Overridden_Subp)))) + and then (not Is_Hidden (Alias (Overridden_Subp)) + or else In_Instance))) then if Must_Not_Override (Spec) then Error_Msg_Sloc := Sloc (Overridden_Subp); @@ -10487,9 +10504,10 @@ package body Sem_Ch6 is is function Check_Conforming_Parameters (E1_Param : Node_Id; - E2_Param : Node_Id) return Boolean; + E2_Param : Node_Id; + Ctype : Conformance_Type) return Boolean; -- Starting from the given parameters, check that all the parameters - -- of two entries or subprograms are subtype conformant. Used to skip + -- of two entries or subprograms are conformant. Used to skip -- the check on the controlling argument. function Matching_Entry_Or_Subprogram @@ -10516,26 +10534,38 @@ package body Sem_Ch6 is -- whose name matches the original name of Subp and has a profile -- conformant with the profile of Subp; return Empty if not found. + function Normalized_First_Parameter_Type + (E : Entity_Id) return Entity_Id; + -- Return the type of the first parameter unless that type + -- is an anonymous access type, in which case return the + -- designated type. Used to treat anonymous-access-to-synchronized + -- the same as synchronized for purposes of checking for + -- prefixed view profile conflicts. + --------------------------------- -- Check_Conforming_Parameters -- --------------------------------- function Check_Conforming_Parameters (E1_Param : Node_Id; - E2_Param : Node_Id) return Boolean + E2_Param : Node_Id; + Ctype : Conformance_Type) return Boolean is Param_E1 : Node_Id := E1_Param; Param_E2 : Node_Id := E2_Param; begin while Present (Param_E1) and then Present (Param_E2) loop - if Ekind (Defining_Identifier (Param_E1)) /= - Ekind (Defining_Identifier (Param_E2)) - or else not + if (Ctype >= Mode_Conformant) and then + Ekind (Defining_Identifier (Param_E1)) /= + Ekind (Defining_Identifier (Param_E2)) + then + return False; + elsif not Conforming_Types (Find_Parameter_Type (Param_E1), Find_Parameter_Type (Param_E2), - Subtype_Conformant) + Ctype) then return False; end if; @@ -10568,7 +10598,8 @@ package body Sem_Ch6 is and then Check_Conforming_Parameters (First (Parameter_Specifications (Parent (E))), - Next (First (Parameter_Specifications (Parent (Subp))))) + Next (First (Parameter_Specifications (Parent (Subp)))), + Type_Conformant) then return E; end if; @@ -10608,7 +10639,8 @@ package body Sem_Ch6 is and then Check_Conforming_Parameters (First (Parameter_Specifications (Parent (Ent))), - Next (First (Parameter_Specifications (Parent (E))))) + Next (First (Parameter_Specifications (Parent (E)))), + Subtype_Conformant) then return E; end if; @@ -10662,6 +10694,21 @@ package body Sem_Ch6 is return Empty; end Matching_Original_Protected_Subprogram; + ------------------------------------- + -- Normalized_First_Parameter_Type -- + ------------------------------------- + + function Normalized_First_Parameter_Type + (E : Entity_Id) return Entity_Id + is + Result : Entity_Id := Etype (First_Entity (E)); + begin + if Ekind (Result) = E_Anonymous_Access_Type then + Result := Designated_Type (Result); + end if; + return Result; + end Normalized_First_Parameter_Type; + -- Start of processing for Has_Matching_Entry_Or_Subprogram begin @@ -10672,20 +10719,23 @@ package body Sem_Ch6 is if Comes_From_Source (E) and then Is_Subprogram (E) and then Present (First_Entity (E)) - and then Is_Concurrent_Record_Type (Etype (First_Entity (E))) + and then Is_Concurrent_Record_Type + (Normalized_First_Parameter_Type (E)) then if Scope (E) = Scope (Corresponding_Concurrent_Type - (Etype (First_Entity (E)))) + (Normalized_First_Parameter_Type (E))) and then Present (Matching_Entry_Or_Subprogram - (Corresponding_Concurrent_Type (Etype (First_Entity (E))), + (Corresponding_Concurrent_Type + (Normalized_First_Parameter_Type (E)), Subp => E)) then Report_Conflict (E, Matching_Entry_Or_Subprogram - (Corresponding_Concurrent_Type (Etype (First_Entity (E))), + (Corresponding_Concurrent_Type + (Normalized_First_Parameter_Type (E)), Subp => E)); return True; end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 313cb4e..6d9a1db 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -925,9 +925,12 @@ package body Sem_Ch7 is -- This is a nested package, so it may be necessary to declare certain -- inherited subprograms that are not yet visible because the parent -- type's subprograms are now visible. + -- Note that for child units these operations were generated when + -- analyzing the package specification. if Ekind (Scope (Spec_Id)) = E_Package and then Scope (Spec_Id) /= Standard_Standard + and then not Is_Child_Unit (Spec_Id) then Declare_Inherited_Private_Subprograms (Spec_Id); end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 38cbf1c..8897b25 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3453,9 +3453,14 @@ package body Sem_Ch8 is if Old_S_Ctrl_Type /= New_S_Ctrl_Type or else No (New_S_Ctrl_Type) then - Error_Msg_NE - ("actual must be dispatching subprogram for type&", - Nam, New_S_Ctrl_Type); + if No (New_S_Ctrl_Type) then + Error_Msg_N + ("actual must be dispatching subprogram", Nam); + else + Error_Msg_NE + ("actual must be dispatching subprogram for type&", + Nam, New_S_Ctrl_Type); + end if; else Set_Is_Dispatching_Operation (New_S); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index bc8ab36..82bf021 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2758,7 +2758,7 @@ package body Sem_Ch9 is Insert_After (N, Obj_Decl); Mark_Rewrite_Insertion (Obj_Decl); - -- Relocate aspect Part_Of from the the original single protected + -- Relocate aspect Part_Of from the original single protected -- declaration to the anonymous object declaration. This emulates the -- placement of an equivalent source pragma. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 0c71f59..f3cac46 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -1457,7 +1457,7 @@ package body Sem_Elab is -- Types -- ----------- - -- The following type enumerates all possible Ghost mode mode kinds + -- The following type enumerates all possible Ghost mode kinds type Extended_Ghost_Mode is (Is_Ignored, @@ -4963,7 +4963,7 @@ package body Sem_Elab is Output_Active_Scenarios (Attr, New_In_State); end if; - -- Treat the attribute an an immediate invocation of the target when + -- Treat the attribute an immediate invocation of the target when -- switch -gnatd.o (conservative elaboration order for indirect -- calls) is in effect. This has the following desirable effects: -- @@ -10015,8 +10015,8 @@ package body Sem_Elab is function Find_Enclosing_Context (N : Node_Id) return Node_Id; pragma Inline (Find_Enclosing_Context); -- Return the nearest enclosing non-library-level or compilation unit - -- node which which encapsulates arbitrary node N. Return Empty is no - -- such context is available. + -- node which encapsulates arbitrary node N. Return Empty is no such + -- context is available. function In_Nested_Context (Outer : Node_Id; @@ -10916,8 +10916,8 @@ package body Sem_Elab is Spec_Id : Entity_Id; begin - -- The the task type has already been expanded, it carries the - -- procedure which emulates the behavior of the task body. + -- The task type has already been expanded, it carries the procedure + -- which emulates the behavior of the task body. if Present (Task_Body_Id) then Spec_Id := Task_Body_Id; @@ -10951,8 +10951,8 @@ package body Sem_Elab is Spec_Id : Entity_Id; begin - -- The the task type has already been expanded, it carries the - -- procedure which emulates the behavior of the task body. + -- The task type has already been expanded, it carries the procedure + -- which emulates the behavior of the task body. if Present (Task_Body_Id) then Spec_Id := Task_Body_Id; diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 477b5f8..0a2bc64 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -224,6 +224,8 @@ package Sem_Eval is -- efficient with compile time known values, e.g. range analysis for the -- purpose of removing checks is more effective if we know precise bounds. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean; -- Similar to Compile_Time_Known_Value, but also returns True if the value -- is a compile-time-known aggregate, i.e. an aggregate all of whose @@ -412,6 +414,8 @@ package Sem_Eval is -- for compile time evaluation purposes. Use Compile_Time_Known_Value -- instead (see section on "Compile-Time Known Values" above). + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Is_OK_Static_Range (N : Node_Id) return Boolean; -- Determines if range is static, as defined in RM 4.9(26), and also checks -- that neither bound of the range raises constraint error, thus ensuring diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 7b36f8e..db4b1b4 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1091,7 +1091,7 @@ package body Sem_Prag is -- template is legal, do not perform this check in -- the instance to circumvent this oddity. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; -- An abstract state with visible refinement cannot @@ -2390,7 +2390,7 @@ package body Sem_Prag is -- do not perform this check in the instance to circumvent -- this oddity. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; -- An abstract state with visible refinement cannot appear @@ -19188,6 +19188,17 @@ package body Sem_Prag is Set_Linker_Section_Pragma (Entity (Corresponding_Aspect (N)), N); + -- Propagate it to its ultimate aliased entity to + -- facilitate the backend processing this attribute + -- in instantiations of generic subprograms. + + if Present (Alias (Entity (Corresponding_Aspect (N)))) + then + Set_Linker_Section_Pragma + (Ultimate_Alias + (Entity (Corresponding_Aspect (N))), N); + end if; + -- Pragma case, we must climb the homonym chain, but skip -- any for which the linker section is already set. @@ -19196,6 +19207,15 @@ package body Sem_Prag is if No (Linker_Section_Pragma (Ent)) then Set_Linker_Section_Pragma (Ent, N); + -- Propagate it to its ultimate aliased entity to + -- facilitate the backend processing this attribute + -- in instantiations of generic subprograms. + + if Present (Alias (Ent)) then + Set_Linker_Section_Pragma + (Ultimate_Alias (Ent), N); + end if; + -- A pragma that applies to a Ghost entity becomes -- Ghost for the purposes of legality checks and -- removal of ignored Ghost code. @@ -26026,18 +26046,17 @@ package body Sem_Prag is -- matched items found in pragma Depends. procedure Check_Output_States - (Spec_Id : Entity_Id; - Spec_Inputs : Elist_Id; + (Spec_Inputs : Elist_Id; Spec_Outputs : Elist_Id; Body_Inputs : Elist_Id; Body_Outputs : Elist_Id); -- Determine whether pragma Depends contains an output state with a -- visible refinement and if so, ensure that pragma Refined_Depends - -- mentions all its constituents as outputs. Spec_Id is the entity of - -- the related subprograms. Spec_Inputs and Spec_Outputs denote the - -- inputs and outputs of the subprogram spec synthesized from pragma - -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs - -- of the subprogram body synthesized from pragma Refined_Depends. + -- mentions all its constituents as outputs. Spec_Inputs and + -- Spec_Outputs denote the inputs and outputs of the subprogram spec + -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote + -- the inputs and outputs of the subprogram body synthesized from pragma + -- Refined_Depends. function Collect_States (Clauses : List_Id) return Elist_Id; -- Given a normalized list of dependencies obtained from calling @@ -26059,11 +26078,8 @@ package body Sem_Prag is -- all special cases. Matched_Items contains the entities of all matched -- items found in pragma Depends. - procedure Report_Extra_Clauses - (Spec_Id : Entity_Id; - Clauses : List_Id); - -- Emit an error for each extra clause found in list Clauses. Spec_Id - -- denotes the entity of the related subprogram. + procedure Report_Extra_Clauses (Clauses : List_Id); + -- Emit an error for each extra clause found in list Clauses ----------------------------- -- Check_Dependency_Clause -- @@ -26327,7 +26343,7 @@ package body Sem_Prag is -- Do not perform this check in an instance because it was already -- performed successfully in the generic template. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then return; end if; @@ -26494,8 +26510,7 @@ package body Sem_Prag is ------------------------- procedure Check_Output_States - (Spec_Id : Entity_Id; - Spec_Inputs : Elist_Id; + (Spec_Inputs : Elist_Id; Spec_Outputs : Elist_Id; Body_Inputs : Elist_Id; Body_Outputs : Elist_Id) @@ -26588,7 +26603,7 @@ package body Sem_Prag is -- Do not perform this check in an instance because it was already -- performed successfully in the generic template. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; -- Inspect the outputs of pragma Depends looking for a state with a @@ -26933,17 +26948,14 @@ package body Sem_Prag is -- Report_Extra_Clauses -- -------------------------- - procedure Report_Extra_Clauses - (Spec_Id : Entity_Id; - Clauses : List_Id) - is + procedure Report_Extra_Clauses (Clauses : List_Id) is Clause : Node_Id; begin -- Do not perform this check in an instance because it was already -- performed successfully in the generic template. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; elsif Present (Clauses) then @@ -27078,8 +27090,7 @@ package body Sem_Prag is -- constituents appear as outputs in the dependency refinement. Check_Output_States - (Spec_Id => Spec_Id, - Spec_Inputs => Spec_Inputs, + (Spec_Inputs => Spec_Inputs, Spec_Outputs => Spec_Outputs, Body_Inputs => Body_Inputs, Body_Outputs => Body_Outputs); @@ -27149,7 +27160,7 @@ package body Sem_Prag is Remove_Extra_Clauses (Refinements, Matched_Items); if Serious_Errors_Detected = Errors then - Report_Extra_Clauses (Spec_Id, Refinements); + Report_Extra_Clauses (Refinements); end if; end if; @@ -27402,7 +27413,7 @@ package body Sem_Prag is -- Do not perform this check in an instance because it was already -- performed successfully in the generic template. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; -- Inspect the In_Out items of the corresponding Global pragma @@ -27511,7 +27522,7 @@ package body Sem_Prag is -- Do not perform this check in an instance because it was already -- performed successfully in the generic template. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; -- Inspect the Input items of the corresponding Global pragma looking @@ -27634,7 +27645,7 @@ package body Sem_Prag is -- Do not perform this check in an instance because it was already -- performed successfully in the generic template. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; -- Inspect the Output items of the corresponding Global pragma @@ -27740,7 +27751,7 @@ package body Sem_Prag is -- Do not perform this check in an instance because it was already -- performed successfully in the generic template. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; -- Inspect the Proof_In items of the corresponding Global pragma @@ -27906,7 +27917,7 @@ package body Sem_Prag is -- Do not perform this check in an instance because it was already -- performed successfully in the generic template. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; elsif Nkind (List) = N_Null then @@ -28157,7 +28168,7 @@ package body Sem_Prag is -- Do not perform this check in an instance because it was already -- performed successfully in the generic template. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; else @@ -28180,7 +28191,7 @@ package body Sem_Prag is -- Do not perform this check in an instance because it was already -- performed successfully in the generic template. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; else @@ -28244,7 +28255,7 @@ package body Sem_Prag is -- body contract is instantiated. Since the generic template is legal, -- do not perform this check in the instance to circumvent this oddity. - if Is_Generic_Instance (Spec_Id) then + if In_Instance then null; -- Non-instance case @@ -28360,7 +28371,7 @@ package body Sem_Prag is -- in the generic template. if Serious_Errors_Detected = Errors - and then not Is_Generic_Instance (Spec_Id) + and then not In_Instance and then not Has_Null_State and then No_Constit then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4a50b09..1c5ae36 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2640,17 +2640,43 @@ package body Sem_Res is Set_Etype (N, Expr_Type); -- AI05-0139-2: Expression is overloaded because type has - -- implicit dereference. If type matches context, no implicit - -- dereference is involved. If the expression is an entity, - -- generate a reference to it, as this is not done for an - -- overloaded construct during analysis. + -- implicit dereference. The context may be the one that + -- requires implicit dereferemce. elsif Has_Implicit_Dereference (Expr_Type) then Set_Etype (N, Expr_Type); Set_Is_Overloaded (N, False); - if Is_Entity_Name (N) then + -- If the expression is an entity, generate a reference + -- to it, as this is not done for an overloaded construct + -- during analysis. + + if Is_Entity_Name (N) + and then Comes_From_Source (N) + then Generate_Reference (Entity (N), N); + + -- Examine access discriminants of entity type, + -- to check whether one of them yields the + -- expected type. + + declare + Disc : Entity_Id := + First_Discriminant (Etype (Entity (N))); + + begin + while Present (Disc) loop + exit when Is_Access_Type (Etype (Disc)) + and then Has_Implicit_Dereference (Disc) + and then Designated_Type (Etype (Disc)) = Typ; + + Next_Discriminant (Disc); + end loop; + + if Present (Disc) then + Build_Explicit_Dereference (N, Disc); + end if; + end; end if; exit Interp_Loop; @@ -3230,7 +3256,7 @@ package body Sem_Res is -- convert implicitly are allowed in membership tests). if Ada_Version >= Ada_2012 - and then Ekind (Ctx_Type) = E_General_Access_Type + and then Ekind (Base_Type (Ctx_Type)) = E_General_Access_Type and then Ekind (Etype (N)) = E_Anonymous_Access_Type and then Nkind (Parent (N)) not in N_Membership_Test then @@ -4691,7 +4717,7 @@ package body Sem_Res is -- Check bad case of atomic/volatile argument (RM C.6(12)) - if Is_By_Reference_Type (Etype (F)) + if (Is_By_Reference_Type (Etype (F)) or else Is_Aliased (F)) and then Comes_From_Source (N) then if Is_Atomic_Object (A) @@ -4965,6 +4991,12 @@ package body Sem_Res is -- the cases of a constraint expression which is an access attribute or -- an access discriminant. + procedure Check_Allocator_Discrim_Accessibility_Exprs + (Curr_Exp : Node_Id; + Alloc_Typ : Entity_Id); + -- Dispatch checks performed by Check_Allocator_Discrim_Accessibility + -- across all expressions within a given conditional expression. + function In_Dispatching_Context return Boolean; -- If the allocator is an actual in a call, it is allowed to be class- -- wide when the context is not because it is a controlling actual. @@ -5016,6 +5048,62 @@ package body Sem_Res is end if; end Check_Allocator_Discrim_Accessibility; + ------------------------------------------------- + -- Check_Allocator_Discrim_Accessibility_Exprs -- + ------------------------------------------------- + + procedure Check_Allocator_Discrim_Accessibility_Exprs + (Curr_Exp : Node_Id; + Alloc_Typ : Entity_Id) + is + Alt : Node_Id; + Expr : Node_Id; + Disc_Exp : constant Node_Id := Original_Node (Curr_Exp); + begin + -- When conditional expressions are constant folded we know at + -- compile time which expression to check - so don't bother with + -- the rest of the cases. + + if Nkind (Curr_Exp) = N_Attribute_Reference then + Check_Allocator_Discrim_Accessibility (Curr_Exp, Alloc_Typ); + + -- Non-constant-folded if expressions + + elsif Nkind (Disc_Exp) = N_If_Expression then + -- Check both expressions if they are still present in the face + -- of expansion. + + Expr := Next (First (Expressions (Disc_Exp))); + if Present (Expr) then + Check_Allocator_Discrim_Accessibility_Exprs (Expr, Alloc_Typ); + Expr := Next (Expr); + if Present (Expr) then + Check_Allocator_Discrim_Accessibility_Exprs + (Expr, Alloc_Typ); + end if; + end if; + + -- Non-constant-folded case expressions + + elsif Nkind (Disc_Exp) = N_Case_Expression then + -- Check all alternatives + + Alt := First (Alternatives (Disc_Exp)); + while Present (Alt) loop + Check_Allocator_Discrim_Accessibility_Exprs + (Expression (Alt), Alloc_Typ); + + Next (Alt); + end loop; + + -- Base case, check the accessibility of the original node of the + -- expression. + + else + Check_Allocator_Discrim_Accessibility (Disc_Exp, Alloc_Typ); + end if; + end Check_Allocator_Discrim_Accessibility_Exprs; + ---------------------------- -- In_Dispatching_Context -- ---------------------------- @@ -5167,7 +5255,8 @@ package body Sem_Res is while Present (Discrim) and then Present (Disc_Exp) loop if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then - Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); + Check_Allocator_Discrim_Accessibility_Exprs + (Disc_Exp, Typ); end if; Next_Discriminant (Discrim); @@ -5225,12 +5314,13 @@ package body Sem_Res is while Present (Discrim) and then Present (Constr) loop if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then if Nkind (Constr) = N_Discriminant_Association then - Disc_Exp := Original_Node (Expression (Constr)); + Disc_Exp := Expression (Constr); else - Disc_Exp := Original_Node (Constr); + Disc_Exp := Constr; end if; - Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); + Check_Allocator_Discrim_Accessibility_Exprs + (Disc_Exp, Typ); end if; Next_Discriminant (Discrim); @@ -7108,6 +7198,14 @@ package body Sem_Res is ("cannot inline & (in potentially unevaluated context)?", N, Nam_UA); + -- Calls cannot be inlined inside the conditions of while + -- loops, as this would create complex actions inside + -- the condition, that are not handled by GNATprove. + + elsif In_While_Loop_Condition (N) then + Cannot_Inline + ("cannot inline & (in while loop condition)?", N, Nam_UA); + -- Do not inline calls which would possibly lead to missing a -- type conversion check on an input parameter. @@ -8478,15 +8576,19 @@ package body Sem_Res is Get_First_Interp (N, I, It); -- If the equality is user-defined, the type of the operands - -- matches that of the formals. For a predefined operqtor, + -- matches that of the formals. For a predefined operator, -- it is the scope that matters, given that the predefined -- equality has Any_Type formals. In either case the result - -- type (most often Booleam) must match the context . + -- type (most often Boolean) must match the context. The scope + -- is either that of the type, if there is a generated equality + -- (when there is an equality for the component type), or else + -- Standard otherwise. while Present (It.Typ) loop if Etype (It.Nam) = Typ and then (Etype (First_Entity (It.Nam)) = Etype (L) + or else Scope (It.Nam) = Standard_Standard or else Scope (It.Nam) = Scope (T)) then Set_Entity (N, It.Nam); @@ -13226,7 +13328,7 @@ package body Sem_Res is if Ada_Version >= Ada_2012 and then not Comes_From_Source (N) and then Is_Rewrite_Substitution (N) - and then Ekind (Target_Type) = E_General_Access_Type + and then Ekind (Base_Type (Target_Type)) = E_General_Access_Type and then Ekind (Opnd_Type) = E_Anonymous_Access_Type then if Is_Itype (Opnd_Type) then diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index fc50524..e5d01dd 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2286,12 +2286,13 @@ package body Sem_Type is -- ration "type P is access Integer" and an anonymous access to Integer, -- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there -- is no rule in 4.6 that allows "access Integer" to be converted to P. + -- Note that this does not preclude one operand to be a pool-specific + -- access type, as a previous version of this code enforced. elsif Ada_Version >= Ada_2005 and then Ekind_In (Etype (L), E_Anonymous_Access_Type, E_Anonymous_Access_Subprogram_Type) and then Is_Access_Type (Etype (R)) - and then Ekind (Etype (R)) /= E_Access_Type then return Etype (L); @@ -2299,7 +2300,6 @@ package body Sem_Type is and then Ekind_In (Etype (R), E_Anonymous_Access_Type, E_Anonymous_Access_Subprogram_Type) and then Is_Access_Type (Etype (L)) - and then Ekind (Etype (L)) /= E_Access_Type then return Etype (R); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4de41d3e..30a2273 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1187,18 +1187,28 @@ package body Sem_Util is is Loc : constant Source_Ptr := Sloc (N); P : constant Node_Id := Prefix (N); + D : Elmt_Id; Id : Node_Id; Index_Typ : Entity_Id; + Sel : Entity_Id := Empty; Desig_Typ : Entity_Id; -- This is either a copy of T, or if T is an access type, then it is -- the directly designated type of this access type. + function Build_Access_Record_Constraint (C : List_Id) return List_Id; + -- If the record component is a constrained access to the current + -- record, the subtype has not been constructed during analysis of + -- the enclosing record type (see Analyze_Access). In that case, build + -- a constrained access subtype after replacing references to the + -- enclosing discriminants with the corresponding discriminant values + -- of the prefix. + function Build_Actual_Array_Constraint return List_Id; -- If one or more of the bounds of the component depends on -- discriminants, build actual constraint using the discriminants - -- of the prefix. + -- of the prefix, as above. function Build_Actual_Record_Constraint return List_Id; -- Similar to previous one, for discriminated components constrained @@ -1286,10 +1296,53 @@ package body Sem_Util is return Constraints; end Build_Actual_Record_Constraint; + ------------------------------------ + -- Build_Access_Record_Constraint -- + ------------------------------------ + + function Build_Access_Record_Constraint (C : List_Id) return List_Id is + Constraints : constant List_Id := New_List; + D : Node_Id; + D_Val : Node_Id; + + begin + -- Retrieve the constraint from the component declaration, because + -- the component subtype has not been constructed and the component + -- type is an unconstrained access. + + D := First (C); + while Present (D) loop + if Nkind (D) = N_Discriminant_Association + and then Denotes_Discriminant (Expression (D)) + then + D_Val := New_Copy_Tree (D); + Set_Expression (D_Val, + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (P), + Selector_Name => + New_Occurrence_Of (Entity (Expression (D)), Loc))); + + elsif Denotes_Discriminant (D) then + D_Val := Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (P), + Selector_Name => New_Occurrence_Of (Entity (D), Loc)); + + else + D_Val := New_Copy_Tree (D); + end if; + + Append (D_Val, Constraints); + Next (D); + end loop; + + return Constraints; + end Build_Access_Record_Constraint; + -- Start of processing for Build_Actual_Subtype_Of_Component begin - -- Why the test for Spec_Expression mode here??? + -- The subtype does not need to be created for a selected component + -- in a Spec_Expression. if In_Spec_Expression then return Empty; @@ -1314,19 +1367,33 @@ package body Sem_Util is Remove_Side_Effects (P); return Build_Actual_Subtype (T, N); end if; + else return Empty; end if; + + elsif Nkind (N) = N_Selected_Component then + -- The entity of the selected component allows us to retrieve + -- the original constraint from its component declaration. + + Sel := Entity (Selector_Name (N)); + if Nkind (Parent (Sel)) /= N_Component_Declaration then + return Empty; + end if; end if; - if Ekind (T) = E_Access_Subtype then + if Is_Access_Type (T) then Desig_Typ := Designated_Type (T); + else Desig_Typ := T; end if; if Ekind (Desig_Typ) = E_Array_Subtype then Id := First_Index (Desig_Typ); + + -- Check whether an index bound is constrained by a discriminant. + while Present (Id) loop Index_Typ := Underlying_Type (Etype (Id)); @@ -1345,6 +1412,7 @@ package body Sem_Util is elsif Is_Composite_Type (Desig_Typ) and then Has_Discriminants (Desig_Typ) + and then not Is_Empty_Elmt_List (Discriminant_Constraint (Desig_Typ)) and then not Has_Unknown_Discriminants (Desig_Typ) then if Is_Private_Type (Desig_Typ) @@ -1364,6 +1432,37 @@ package body Sem_Util is Next_Elmt (D); end loop; + + -- Special processing for an access record component that is + -- the target of an assignment. If the designated type is an + -- unconstrained discriminated record we create its actual + -- subtype now. + + elsif Ekind (T) = E_Access_Type + and then Present (Sel) + and then Has_Per_Object_Constraint (Sel) + and then Nkind (Parent (N)) = N_Assignment_Statement + and then N = Name (Parent (N)) + -- and then not Inside_Init_Proc + -- and then Has_Discriminants (Desig_Typ) + -- and then not Is_Constrained (Desig_Typ) + then + declare + S_Indic : constant Node_Id := + (Subtype_Indication + (Component_Definition (Parent (Sel)))); + Discs : List_Id; + begin + if Nkind (S_Indic) = N_Subtype_Indication then + Discs := Constraints (Constraint (S_Indic)); + + Remove_Side_Effects (P); + return Build_Component_Subtype + (Build_Access_Record_Constraint (Discs), Loc, T); + else + return Empty; + end if; + end; end if; -- If none of the above, the actual and nominal subtypes are the same @@ -6488,7 +6587,7 @@ package body Sem_Util is -- Local variables - Expr : constant Node_Id := Original_Node (N); + Expr : Node_Id := Original_Node (N); -- Expr references the original node because at this stage N may be the -- reference to a variable internally created by the frontend to remove -- side effects of an expression. @@ -6513,9 +6612,31 @@ package body Sem_Util is end if; end if; + -- Handle a constant-folded conditional expression by avoiding use of + -- the original node. + + if Nkind_In (Expr, N_Case_Expression, N_If_Expression) then + Expr := N; + end if; + -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? case Nkind (Expr) is + -- It may be possible that we have an access object denoted by an + -- attribute reference for 'Loop_Entry which may, in turn, have an + -- indexed component representing a loop identifier. + + -- In this case we must climb up the indexed component and set expr + -- to the attribute reference so the rest of the machinery can + -- operate as expected. + + when N_Indexed_Component => + if Nkind (Prefix (Expr)) = N_Attribute_Reference + and then Get_Attribute_Id (Attribute_Name (Prefix (Expr))) + = Attribute_Loop_Entry + then + Expr := Prefix (Expr); + end if; -- For access discriminant, the level of the enclosing object @@ -6530,6 +6651,13 @@ package body Sem_Util is when N_Attribute_Reference => case Get_Attribute_Id (Attribute_Name (Expr)) is + -- Ignore 'Loop_Entry, 'Result, and 'Old as they can be used to + -- identify access objects and do not have an effect on + -- accessibility level. + + when Attribute_Loop_Entry | Attribute_Old | Attribute_Result => + null; + -- For X'Access, the level of the prefix X when Attribute_Access => @@ -12727,6 +12855,30 @@ package body Sem_Util is and then not In_Private_Part (Scope_Id); end In_Visible_Part; + ----------------------------- + -- In_While_Loop_Condition -- + ----------------------------- + + function In_While_Loop_Condition (N : Node_Id) return Boolean is + Prev : Node_Id := N; + P : Node_Id := Parent (N); + -- P and Prev will be used for traversing the AST, while maintaining an + -- invariant that P = Parent (Prev). + begin + loop + if No (P) then + return False; + elsif Nkind (P) = N_Iteration_Scheme + and then Prev = Condition (P) + then + return True; + else + Prev := P; + P := Parent (P); + end if; + end loop; + end In_While_Loop_Condition; + -------------------------------- -- Incomplete_Or_Partial_View -- -------------------------------- @@ -13572,54 +13724,33 @@ package body Sem_Util is ---------------------- function Is_Atomic_Object (N : Node_Id) return Boolean is - function Is_Atomic_Entity (Id : Entity_Id) return Boolean; - pragma Inline (Is_Atomic_Entity); - -- Determine whether arbitrary entity Id is either atomic or has atomic + function Prefix_Has_Atomic_Components (Pref : Node_Id) return Boolean; + -- Determine whether prefix Pref of an indexed component has atomic -- components. - function Is_Atomic_Prefix (Pref : Node_Id) return Boolean; - -- Determine whether prefix Pref of an indexed or selected component is - -- an atomic object. - - ---------------------- - -- Is_Atomic_Entity -- - ---------------------- - - function Is_Atomic_Entity (Id : Entity_Id) return Boolean is - begin - return Is_Atomic (Id) or else Has_Atomic_Components (Id); - end Is_Atomic_Entity; - - ---------------------- - -- Is_Atomic_Prefix -- - ---------------------- + --------------------------------- + -- Prefix_Has_Atomic_Components -- + --------------------------------- - function Is_Atomic_Prefix (Pref : Node_Id) return Boolean is + function Prefix_Has_Atomic_Components (Pref : Node_Id) return Boolean is Typ : constant Entity_Id := Etype (Pref); begin if Is_Access_Type (Typ) then return Has_Atomic_Components (Designated_Type (Typ)); - elsif Is_Atomic_Entity (Typ) then + elsif Has_Atomic_Components (Typ) then return True; elsif Is_Entity_Name (Pref) - and then Is_Atomic_Entity (Entity (Pref)) + and then Has_Atomic_Components (Entity (Pref)) then return True; - elsif Nkind (Pref) = N_Indexed_Component then - return Is_Atomic_Prefix (Prefix (Pref)); - - elsif Nkind (Pref) = N_Selected_Component then - return - Is_Atomic_Prefix (Prefix (Pref)) - or else Is_Atomic (Entity (Selector_Name (Pref))); + else + return False; end if; - - return False; - end Is_Atomic_Prefix; + end Prefix_Has_Atomic_Components; -- Start of processing for Is_Atomic_Object @@ -13628,12 +13759,13 @@ package body Sem_Util is return Is_Atomic_Object_Entity (Entity (N)); elsif Nkind (N) = N_Indexed_Component then - return Is_Atomic (Etype (N)) or else Is_Atomic_Prefix (Prefix (N)); + return + Is_Atomic (Etype (N)) + or else Prefix_Has_Atomic_Components (Prefix (N)); elsif Nkind (N) = N_Selected_Component then return Is_Atomic (Etype (N)) - or else Is_Atomic_Prefix (Prefix (N)) or else Is_Atomic (Entity (Selector_Name (N))); end if; @@ -13658,8 +13790,8 @@ package body Sem_Util is function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is begin return Is_Atomic_Object (N) - or else (Is_Object_Reference (N) - and then Is_Entity_Name (N) + or else (Is_Entity_Name (N) + and then Is_Object (Entity (N)) and then (Is_Volatile_Full_Access (Entity (N)) or else Is_Volatile_Full_Access (Etype (Entity (N))))); @@ -23174,13 +23306,16 @@ package body Sem_Util is Item := Corresponding_Aspect (Item); end if; - -- Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class, + -- Retrieve the name of the aspect/pragma. As assertion pragmas from + -- a generic instantiation might have been rewritten into pragma Check, + -- we look at the original node for Item. Note also that Pre, Pre_Class, -- Post and Post_Class rewrite their pragma identifier to preserve the - -- original name. + -- original name, so we look at the original node for the identifier. -- ??? this is kludgey if Nkind (Item) = N_Pragma then - Item_Nam := Chars (Original_Node (Pragma_Identifier (Item))); + Item_Nam := + Chars (Original_Node (Pragma_Identifier (Original_Node (Item)))); else pragma Assert (Nkind (Item) = N_Aspect_Specification); @@ -24593,8 +24728,9 @@ package body Sem_Util is -- 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) + elsif Ekind (Implementation_Base_Type (Curr)) = E_Task_Type + and then + Outer = Task_Body_Procedure (Implementation_Base_Type (Curr)) then return True; @@ -24635,8 +24771,9 @@ package body Sem_Util is if Curr = Outer then return True; - elsif Ekind (Curr) = E_Task_Type - and then Outer = Task_Body_Procedure (Curr) + elsif Ekind (Implementation_Base_Type (Curr)) = E_Task_Type + and then + Outer = Task_Body_Procedure (Implementation_Base_Type (Curr)) then return True; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index dc5e57b..c354d7e 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -566,6 +566,8 @@ package Sem_Util is -- debugging information, generated through Qualify_Entity_Names, and -- the loop declaration must be placed in the table Name_Qualify_Units. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Denotes_Discriminant (N : Node_Id; Check_Concurrent : Boolean := False) return Boolean; @@ -901,6 +903,8 @@ package Sem_Util is -- Note that the value returned is always the expression (not the -- N_Parameter_Association nodes, even if named association is used). + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function First_Global (Subp : Entity_Id; Global_Mode : Name_Id; @@ -1442,6 +1446,9 @@ package Sem_Util is -- package specification. The package must be on the scope stack, and the -- corresponding private part must not. + function In_While_Loop_Condition (N : Node_Id) return Boolean; + -- Returns true if the expression N occurs within the condition of a while + function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id; -- Given the entity of a constant or a type, retrieve the incomplete or -- partial view of the same entity. Note that Id may not have a partial @@ -1524,7 +1531,9 @@ package Sem_Util is function Is_Atomic_Object (N : Node_Id) return Boolean; -- Determine whether arbitrary node N denotes a reference to an atomic - -- object as per Ada RM C.6(12). + -- object as per Ada RM C.6(7) and the crucial remark in C.6(8). + + -- WARNING: There is a matching C declaration of this subprogram in fe.h function Is_Atomic_Object_Entity (Id : Entity_Id) return Boolean; -- Determine whether arbitrary entity Id denotes an atomic object as per @@ -2062,6 +2071,8 @@ package Sem_Util is function Is_Variable_Size_Record (E : Entity_Id) return Boolean; -- Returns true if E has variable size components + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Is_Variable (N : Node_Id; Use_Original_Node : Boolean := True) return Boolean; @@ -2093,6 +2104,8 @@ package Sem_Util is -- for something actually declared as volatile, not for an object that gets -- treated as volatile (see Einfo.Treat_As_Volatile). + -- WARNING: There is a matching C declaration of this subprogram in fe.h + generic with procedure Handle_Parameter (Formal : Entity_Id; Actual : Node_Id); procedure Iterate_Call_Parameters (Call : Node_Id); @@ -2361,11 +2374,6 @@ package Sem_Util is -- when the resulting entity does not have to be referenced as a -- public entity (and in this case Is_Public is not set). - procedure Next_Actual (Actual_Id : in out Node_Id); - pragma Inline (Next_Actual); - -- Next_Actual (N) is equivalent to N := Next_Actual (N). Note that we - -- inline this procedural form, but not the functional form that follows. - function Next_Actual (Actual_Id : Node_Id) return Node_Id; -- Find next actual parameter in declaration order. As described for -- First_Actual, this is the next actual in the declaration order, not @@ -2375,16 +2383,23 @@ package Sem_Util is -- Note that the result produced is always an expression, not a parameter -- association node, even if named notation was used. - procedure Next_Global (Node : in out Node_Id); + -- WARNING: There is a matching C declaration of this subprogram in fe.h + + procedure Next_Actual (Actual_Id : in out Node_Id); pragma Inline (Next_Actual); - -- Next_Global (N) is equivalent to N := Next_Global (N). Note that we - -- inline this procedural form, but not the functional form that follows. + -- Next_Actual (N) is equivalent to N := Next_Actual (N). Note that we + -- inline this procedural form, but not the functional form above. function Next_Global (Node : Node_Id) return Node_Id; -- Node is a global item from a list, obtained through calling First_Global -- and possibly Next_Global a number of times. Returns the next global item -- with the same mode. + procedure Next_Global (Node : in out Node_Id); + pragma Inline (Next_Actual); + -- Next_Global (N) is equivalent to N := Next_Global (N). Note that we + -- inline this procedural form, but not the functional form above. + function No_Caching_Enabled (Id : Entity_Id) return Boolean; -- Given the entity of a variable, determine whether Id is subject to -- volatility property No_Caching and if it is, the related expression @@ -2588,6 +2603,8 @@ package Sem_Util is -- controlled types and variable-sized types including unconstrained -- arrays. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Reset_Analyzed_Flags (N : Node_Id); -- Reset the Analyzed flags in all nodes of the tree whose root is N diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 2689ebe..b99a32d 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -269,6 +269,14 @@ package body Sinfo is return Node3 (N); end Array_Aggregate; + function Aspect_On_Partial_View + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification); + return Flag18 (N); + end Aspect_On_Partial_View; + function Aspect_Rep_Item (N : Node_Id) return Node_Id is begin @@ -3763,6 +3771,14 @@ package body Sinfo is Set_Node3_With_Parent (N, Val); end Set_Array_Aggregate; + procedure Set_Aspect_On_Partial_View + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification); + Set_Flag18 (N, Val); + end Set_Aspect_On_Partial_View; + procedure Set_Aspect_Rep_Item (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 5a92066..5e04772 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -933,6 +933,12 @@ package Sinfo is -- is used for translation of the at end handler into a normal exception -- handler. + -- Aspect_On_Partial_View (Flag18) + -- Present on an N_Aspect_Specification node. For an aspect that applies + -- to a type entity, indicates whether the specification appears on the + -- partial view of a private type or extension. Undefined for aspects + -- that apply to other entities. + -- Aspect_Rep_Item (Node2-Sem) -- Present in N_Aspect_Specification nodes. Points to the corresponding -- pragma/attribute definition node used to process the aspect. @@ -7638,6 +7644,7 @@ package Sinfo is -- Is_Disabled (Flag15-Sem) -- Is_Boolean_Aspect (Flag16-Sem) -- Split_PPC (Flag17) Set if split pre/post attribute + -- Aspect_On_Partial_View (Flag18-Sem) -- Note: Aspect_Specification is an Ada 2012 feature @@ -9299,6 +9306,9 @@ package Sinfo is function Array_Aggregate (N : Node_Id) return Node_Id; -- Node3 + function Aspect_On_Partial_View + (N : Node_Id) return Boolean; -- Flag18 + function Aspect_Rep_Item (N : Node_Id) return Node_Id; -- Node2 @@ -10343,6 +10353,8 @@ package Sinfo is -- tree pointers (List1-4), the parent pointer of the Val node is set to -- point back to node N. This automates the setting of the parent pointer. + -- WARNING: There is a matching C declaration of a few subprograms in fe.h + procedure Set_Abort_Present (N : Node_Id; Val : Boolean := True); -- Flag15 @@ -10409,6 +10421,9 @@ package Sinfo is procedure Set_Array_Aggregate (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Aspect_On_Partial_View + (N : Node_Id; Val : Boolean := True); -- Flag18 + procedure Set_Aspect_Rep_Item (N : Node_Id; Val : Node_Id); -- Node2 @@ -11458,6 +11473,8 @@ package Sinfo is -- returns the location of the IF token in the END IF sequence by -- translating the value of the End_Span field. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Set_End_Location (N : Node_Id; S : Source_Ptr); -- N is an N_If_Statement or N_Case_Statement node. This procedure sets -- the End_Span field to correspond to the given value S. In other words, @@ -13320,6 +13337,7 @@ package Sinfo is pragma Inline (Ancestor_Part); pragma Inline (Atomic_Sync_Required); pragma Inline (Array_Aggregate); + pragma Inline (Aspect_On_Partial_View); pragma Inline (Aspect_Rep_Item); pragma Inline (Assignment_OK); pragma Inline (Associated_Node); @@ -13686,6 +13704,7 @@ package Sinfo is pragma Inline (Set_Alternatives); pragma Inline (Set_Ancestor_Part); pragma Inline (Set_Array_Aggregate); + pragma Inline (Set_Aspect_On_Partial_View); pragma Inline (Set_Aspect_Rep_Item); pragma Inline (Set_Assignment_OK); pragma Inline (Set_Associated_Node); diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index 0ef781c..c968eed 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -293,6 +293,8 @@ package Sinput is -- will be 1 since system.ads is read first. function Debug_Source_Name (S : SFI) return File_Name_Type; + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function File_Name (S : SFI) return File_Name_Type; function File_Type (S : SFI) return Type_Of_File; function First_Mapped_Line (S : SFI) return Logical_Line_Number; @@ -532,6 +534,8 @@ package Sinput is -- determined and returned. Tab characters if present are assumed to -- represent the standard 1,9,17.. spacing pattern. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Get_Logical_Line_Number (P : Source_Ptr) return Logical_Line_Number; -- The line number of the specified source position is obtained by @@ -543,6 +547,8 @@ package Sinput is -- reference pragmas have been encountered, the value returned is -- the same as the physical line number. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Get_Logical_Line_Number_Img (P : Source_Ptr) return String; -- Same as above function, but returns the line number as a string of @@ -561,6 +567,8 @@ package Sinput is -- value. This call must always succeed, since any valid source pointer -- value belongs to some previously loaded source file. + -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Instantiation_Depth (S : Source_Ptr) return Nat; -- Determine instantiation depth for given Sloc value. A value of -- zero means that the given Sloc is not in an instantiation. diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads index 722d17f..2ceb20c 100644 --- a/gcc/ada/stringt.ads +++ b/gcc/ada/stringt.ads @@ -42,6 +42,9 @@ package Stringt is -- additional string constants generated by compile time concatenation and -- other similar processing. +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file stringt.h + -- A string constant in this table consists of a series of Char_Code values, -- so that 16-bit character codes can be properly handled if this feature -- is implemented in the scanner. diff --git a/gcc/ada/stringt.h b/gcc/ada/stringt.h index 371acdf..911c61b 100644 --- a/gcc/ada/stringt.h +++ b/gcc/ada/stringt.h @@ -23,8 +23,10 @@ * * ****************************************************************************/ -/* This file is the C file that corresponds to the Ada package spec - Stringt. It was created manually from stringt.ads and stringt.adb +/* This is the C header that corresponds to the Ada package specification for + Stringt. It also contains the implementations of inlined functions from the + package body for Stringt. It was created manually from stringt.ads and + stringt.adb and must be kept synchronized with changes in these files. Note: only the access functions are provided, since the tree transformer is not allowed to modify the tree or its auxiliary structures. diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index e8139ba..d9465b5 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -455,12 +455,16 @@ package Targparm is Stack_Check_Probes_On_Target : Boolean := False; -- Indicates if the GCC probing mechanism is used + -- WARNING: There is a matching C declaration of this variable in fe.h + Stack_Check_Limits_On_Target : Boolean := False; -- Indicates if the GCC stack-limit mechanism is used -- Both flags cannot be simultaneously set to True. If neither -- is, the target independent fallback method is used. + -- WARNING: There is a matching C declaration of this variable in fe.h + Stack_Check_Default_On_Target : Boolean := False; -- Indicates if stack checking is on by default @@ -536,9 +540,13 @@ package Targparm is Machine_Overflows_On_Target : Boolean := False; -- Set to True for targets where S'Machine_Overflows is True + -- WARNING: There is a matching C declaration of this variable in fe.h + Signed_Zeros_On_Target : Boolean := True; -- Set to False on targets that do not reliably support signed zeros + -- WARNING: There is a matching C declaration of this variable in fe.h + ------------------------------------------- -- Boolean-Valued Fixed-Point Attributes -- ------------------------------------------- diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 1297451..e649c4e 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -38,7 +38,7 @@ -- would have to be dealt with. -- WARNING: There is a C version of this package. Any changes to this source --- file must be properly reflected in the C header file types.h declarations. +-- file must be properly reflected in the C header file types.h -- Note: the declarations in this package reflect an expectation that the host -- machine has an efficient integer base type with a range at least 32 bits diff --git a/gcc/ada/types.h b/gcc/ada/types.h index 94dc22c..a87340d 100644 --- a/gcc/ada/types.h +++ b/gcc/ada/types.h @@ -23,8 +23,9 @@ * * ****************************************************************************/ -/* This is the C file that corresponds to the Ada package spec Types. It was - created manually from the files types.ads and types.adb. +/* This is the C header that corresponds to the Ada package specification for + Types. It was created manually from types.ads and must be kept synchronized + with changes in this file. This package contains host independent type definitions which are used throughout the compiler modules. The comments in the C version are brief @@ -306,6 +307,9 @@ typedef Int Unit_Number_Type; /* Unit number value for main unit. */ #define Main_Unit 0 +/* Type used to index the source file table. */ +typedef Nat Source_File_Index; + /* Type used for lines table. */ typedef Source_Ptr *Lines_Table_Type; diff --git a/gcc/ada/uintp.h b/gcc/ada/uintp.h index ad1b8c5..ed106ef 100644 --- a/gcc/ada/uintp.h +++ b/gcc/ada/uintp.h @@ -23,8 +23,9 @@ * * ****************************************************************************/ -/* This file corresponds to the Ada package specification Uintp. It was - created manually from the files uintp.ads and uintp.adb. */ +/* This is the C header that corresponds to the Ada package specification for + Uintp. It was created manually from uintp.ads and must be kept synchronized + with changes in this file. */ #ifdef __cplusplus extern "C" { diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads index 585d894..55a82f2 100644 --- a/gcc/ada/urealp.ads +++ b/gcc/ada/urealp.ads @@ -31,6 +31,9 @@ -- Support for universal real arithmetic +-- WARNING: There is a C version of this package. Any changes to this +-- source file must be properly reflected in the C header file urealp.h + with Types; use Types; with Uintp; use Uintp; diff --git a/gcc/ada/urealp.h b/gcc/ada/urealp.h index 413e710..ab8656b 100644 --- a/gcc/ada/urealp.h +++ b/gcc/ada/urealp.h @@ -23,8 +23,9 @@ * * ****************************************************************************/ -/* This file corresponds to the Ada package specification Urealp. It was - created manually from the files urealp.ads and urealp.adb. */ +/* This is the C header that corresponds to the Ada package specification for + Urealp. It was created manually from urealp.ads and must be kept + synchronized with changes in this file. */ #ifdef __cplusplus extern "C" { diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads index 0a3253e..c82f36d 100644 --- a/gcc/ada/warnsw.ads +++ b/gcc/ada/warnsw.ads @@ -63,6 +63,8 @@ package Warnsw is -- efficiency reasons and would be improved by reordering the components. -- Off by default, modified by use of -gnatw.q/.Q (but not -gnatwa). + -- WARNING: There is a matching C declaration of this variable in fe.h + Warn_On_Record_Holes : Boolean := False; -- Warn when explicit record component clauses leave uncovered holes (gaps) -- in a record layout. Off by default, set by -gnatw.h (but not -gnatwa). |