diff options
Diffstat (limited to 'gcc/ada')
60 files changed, 4132 insertions, 1336 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b66c7ba..821e3c0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,432 @@ +2025-07-28 Marc Poulhiès <poulhies@adacore.com> + + * gcc-interface/trans.cc (gnat_to_gnu): Fix typo in comment. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * gcc-interface/misc.cc: Make + diagnostics::context::m_source_printing private. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * gcc-interface/trans.cc: Update for diagnostic_t becoming + enum class diagnostics::kind. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * gcc-interface/misc.cc: Update for diagnostic_context becoming + diagnostics::context. + +2025-07-25 Marc Poulhiès <poulhies@adacore.com> + + * gcc-interface/utils.cc (update_pointer_to): Renamed ptr/old_ptr, ref/old_ref. + +2025-07-25 Alexandre Oliva <oliva@adacore.com> + + * s-oscons-tmplt.c (CLOCK_RT_Ada) [__vxworks]: Define to + CLOCK_REALTIME on VxWorks6. + * gsocket.h [__vxworks]: Include strings.h if available. + * sysdep.c [__vxworks]: Likewise. + +2025-07-25 Steve Baird <baird@adacore.com> + + * exp_ch6.adb (Apply_Access_Discrims_Accessibility_Check): Do + nothing and simply return if either Ada_Version <= Ada_95 or if + the function being returned from lacks the extra formal parameter + needed to perform the check (typically because the result is + tagged). + +2025-07-25 Bob Duff <duff@adacore.com> + + * sem_ch12.adb (Check_Formal_Package_Instance): + Do nothing in case of E_Subprogram_Body. + +2025-07-25 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Process_Discriminants): Update comments + +2025-07-25 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Build_Derived_Record_Type): Set flag appropriately. + +2025-07-25 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/a-calend.adb (To_Struct_Timespec_64): Deal with negative + Duration values and truncate the nanoseconds too. + * libgnat/g-calend.adb (timeval_to_duration): Unsuppress overflow + checks. + (duration_to_timeval): Likewise. Deal with negative Duration values + as well as integral Duration values. + * libgnat/g-socket.adb (To_Timeval): Simplify the implementation. + +2025-07-24 Steve Baird <baird@adacore.com> + + * exp_aggr.adb (Convert_To_Assignments): Add calls to Ensure_Defined + before generating assignments to components that could be + associated with a not-yet-defined itype. + +2025-07-24 Steve Baird <baird@adacore.com> + + * accessibility.adb (Function_Call_Or_Allocator_Level): Handle the + case where a function that has an Extra_Accessibility_Of_Result + parameter returns as its result a call to another such function. + In that case, the extra parameter should be passed along. + (Check_Return_Construct_Accessibility): Replace a warning about an + inevitable failure of a dynamic check with a legality-rule-violation + error message; adjust the text of the message accordingly. + * exp_ch6.ads (Apply_Access_Discrims_Accessibility_Check): New + procedure, following example of the existing + Apply_CW_Accessibility procedure. + * exp_ch6.adb (Apply_Access_Discrims_Accessibility_Check): body + for new procedure. + (Expand_Simple_Function_Return): Add call to new + Apply_Access_Discrims_Accessibility_Check procedure. + * exp_ch3.adb (Make_Allocator_For_Return): Add call to new + Apply_Access_Discrims_Accessibility_Check procedure. + +2025-07-24 Tonu Naks <naks@adacore.com> + + * doc/gnat_rm/standard_and_implementation_defined_restrictions.rst: + clarify parameter description. + * gnat_rm.texi: Regenerate. + +2025-07-22 Gary Dismukes <dismukes@adacore.com> + + * sem_ch8.adb (End_Use_Type): Add a test for there not being an earlier + use_type_clause for the same type as an additional criterion for turning + off In_Use and Current_Use_Clause. + +2025-07-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_attr.adb (Eval_Attribute): Only fold array attributes when prefix + is static or at least safe to evaluate + +2025-07-22 Ronan Desplanques <desplanques@adacore.com> + + * einfo.ads (Is_Controlled_Active): Fix pasto in comment. + * sem_util.ads (Propagate_Controlled_Flags): Update comment for + Destructor aspect. + +2025-07-22 Ronan Desplanques <desplanques@adacore.com> + + * doc/gnat_rm/gnat_language_extensions.rst: Document new extension. + * snames.ads-tmpl: Add name for new aspect. + * gen_il-fields.ads (Has_Destructor, Is_Destructor): Add new fields. + * gen_il-gen-gen_entities.adb (E_Procedure, Type_Kind): Add new fields. + * einfo.ads (Has_Destructor, Is_Destructor): Document new fields. + * aspects.ads: Add new aspect. + * sem_ch13.adb (Analyze_Aspect_Specifications, + Check_Aspect_At_Freeze_Point, Check_Aspect_At_End_Of_Declarations): + Add semantic analysis for new aspect. + (Resolve_Finalization_Procedure): New function. + (Resolve_Finalizable_Argument): Use new function above. + * sem_util.adb (Propagate_Controlled_Flags): Extend for new field. + * freeze.adb (Freeze_Entity): Add legality check for new aspect. + * exp_ch3.adb (Expand_Freeze_Record_Type, Predefined_Primitive_Bodies): + Use new field. + * exp_ch7.adb (Build_Finalize_Statements): Add expansion for + destructors. + (Make_Final_Call, Build_Record_Deep_Procs): Adapt to new Has_Destructor + field. + (Build_Adjust_Statements): Tweak to handle cases of empty lists. + * gnat_rm.texi: Regenerate. + +2025-07-22 Denis Mazzucato <mazzucato@adacore.com> + + * sem_ch6.adb (Might_Need_BIP_Task_Actuals): Before retrieving the original corresponding + operation we retrieve first the root of the aliased chain. + +2025-07-22 Ronan Desplanques <desplanques@adacore.com> + + * gen_il-fields.ads (Is_Implicit_Full_View): New field. + * gen_il-gen-gen_entities.adb (Type_Kind): Use new field. + * einfo.ads (Is_Implicit_Full_View): Document new field. + * exp_ch7.adb (Make_Adjust_Call, Make_Init_Call, Make_Final_Call): Use + new field. + * exp_util.adb (Finalize_Address): Likewise. + * sem_ch3.adb (Copy_And_Build): Set new field. + +2025-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.ads (May_Generate_Large_Temp): Delete. + * exp_util.adb (May_Generate_Large_Temp): Likewise. + (Safe_Unchecked_Type_Conversion): Do not take stack checking into + account to compute the result. + +2025-07-22 Javier Miranda <miranda@adacore.com> + + * sinfo.ads (Is_Expanded_Dispatching_Call): New flag. + (Tag_Propagated): New flag. + * exp_ch6.adb (Expand_Call_Helper): Propagate the tag when + the dispatching call is placed in conditionl expressions or + case-expressions. + * sem_ch5.adb (Analyze_Assignment): For assignment of tag- + indeterminate expression, do not propagate the tag if + previously done. + * sem_disp.adb (Is_Tag_Indeterminate): Add missing support + for conditional expression and case expression. + * exp_disp.ads (Is_Expanded_Dispatching_Call): Removed. Function + replaced by a new flag in the nodes. + * exp_disp.adb (Expand_Dispatching_Call): Set a flag in the + call node to remember that the call has been expanded. + (Is_Expanded_Dispatching_Call): Function removed. + * gen_il-fields.ads (Tag_Propagated): New flag. + (Is_Expanded_Dispatching_Call): New flag. + * gen_il-gen-gen_nodes.adb (Tag_Propagated): New flag. + (Is_Expanded_Dispatching_Call): New flag. + +2025-07-22 Gary Dismukes <dismukes@adacore.com> + + * libgnat/a-cbhama.ads (Empty): Add missing default to Capacity formal. + * libgnat/a-cbhama.adb (Empty): Add missing default to Capacity formal. + * exp_aggr.adb (Build_Size_Expr): Test for presence of Capacity + discriminant as additional criterion for generating the call to + the Length function. Update comments. + +2025-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.adb (Safe_Unchecked_Type_Conversion): Always return True + if the expression is the prefix of an N_Selected_Component. + +2025-07-22 Denis Mazzucato <mazzucato@adacore.com> + + * sem_ch6.adb (Might_Need_BIP_Task_Actuals): Check whether No_Task_Parts is enabled in any + of the derived types, or interfaces, from the user-defined primitive return type. + * sem_ch13.adb (Analyze_Aspect_Specifications): Add No_Task_Parts and No_Controlled_Parts to + the representation chain to be visible in the full view of private types. + * aspects.ads (Nonoverridable_Aspect_Id): As per GNAT RM, No_Task_Parts is nonoverridable. + * sem_util.adb (Check_Inherited_Nonoverridable_Aspects): Likewise. + * sem_util.ads: Fix typo and style. + * sem_disp.adb: Missing comment. + +2025-07-22 Javier Miranda <miranda@adacore.com> + + * einfo.ads (Extra_Formals): Complete documentation. + (Has_First_Controlling_Parameter_Aspect): Place it in alphabetical order. + (Has_Frozen_Extra_Formals): New attribute. + * gen_il-fields.ads (Has_Frozen_Extra_Formals): New entity field. + * gen_il-gen-gen_entities.adb (Has_Frozen_Extra_Formals): Adding new + entity flag to subprograms, subprogram types, and and entries. + * gen_il-internals.adb (Image): Adding Has_Frozen_Extra_Formals. + * exp_ch3.adb (Build_Array_Init_Proc): Freeze its extra formals. + (Build_Init_Procedure): Freeze its extra formals. + (Expand_Freeze_Record_Type): For tagged types with foreign convention + create the extra formals of primitives with convention Ada. + * exp_ch6.ads (Create_Extra_Actuals): New subprogram. + * exp_ch6.adb (Check_BIP_Actuals): Adding assertions. + (Create_Extra_Actuals): New subprogram that factorizes code from + Expand_Call_Helper. + (Expand_Call_Helper): Adding support to defer the addition of extra + actuals. Move the code that adds the extra actuals to a new subprogram. + (Is_Unchecked_Union_Equality): Renamed as Is_Unchecked_Union_Predefined_ + Equality_Call. + * exp_ch7.adb (Create_Finalizer): Freeze its extra formals. + (Wrap_Transient_Expression): Link the temporary with its relocated + expression to facilitate locating the expression in the expanded code. + * exp_ch9.ads (Expand_N_Entry_Declaration): Adding one formal. + * exp_ch9.adb (Expand_N_Entry_Declaration): Defer the expansion of + the entry if the extra formals are not available; analyze the built + declarations for the record type that holds all the parameters if + the expansion of the entry declaration was deferred. + * exp_disp.adb (Expand_Dispatching_Call): Handle deferred extra formals. + (Set_CPP_Constructors): Freeze its extra formals. + * freeze.adb (Freeze_Entity): Create the extra actuals of acccess to + subprograms whose designated type is a subprogram type. + (Freeze_Subprogram): Adjust assertion to support deferred extra formals, + and freeze extra formals of non-dispatching subprograms with foreign + convention. Added assertion to check matching of formals in thunks. + * sem_aux.adb (Get_Called_Entity): Adding documentation. + * sem_ch3.adb (Analyze_Full_Type_Declaration): Create the extra formals + of deferred subprograms, subprogram types and entries; create also the + extra actuals of deferred calls. + * sem_ch6.ads (Freeze_Extra_Formals): New subprogram. + (Deferred_Extra_Formals_Support): New package. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Create the extra formals + of subprograms without separate spec. + (Add_Extra_Formal): Add documentation. + (Has_Extra_Formals): Removed. + (Parent_Subprogram): Adding documentation. + (Create_Extra_Formals): Defer adding extra formals if the underlying_type + of some formal type or return type is not available. + (Extra_Formals_Match_OK): Add missing check on the extra formals of + unchecked unions. + (Freeze_Extra_Formals): New subprogram. + (Deferred_Extra_Formals_Support): New package. + * sem_ch9.adb (Analyze_Entry_Declaration): Freeze its extra formals. + * sem_ch13.adb (New_Put_Image_Subprogram): ditto. + * sem_util.ads (Is_Unchecked_Union_Equality): New subprogram. + * sem_util.adb (Is_Unchecked_Union_Equality): ditto. + +2025-07-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Get_Actual_Subtype): Do the same for GCC and GNATprove + backends. + +2025-07-22 Martin Clochard <clochard@adacore.com> + + * exp_spark.adb (Expand_SPARK): Add expansion of continue statements. + (Expand_SPARK_N_Continue_Statement): Expand continue statements resolved + as procedure calls into said procedure calls. + +2025-07-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Call): Look at the base type of actual parameter + when checking call to Set_Handler. + +2025-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * sem_util.adb (Get_Actual_Subtype): Only create a new subtype when + the expander is active. Remove a useless test of type inequality, + as well as a useless call to Set_Has_Delayed_Freeze on the subtype. + +2025-07-22 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Build_Size_Expr): Change test of "not Present (...)" + to "No (...)". + +2025-07-22 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Build_Size_Expr): Determine the length of a container + aggregate association in the case where it's an iteration over an + object of a container type coming from an instantiation of a predefined + container generic. Minor updates to existing comments. + +2025-07-22 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_util.adb (Finalize_Address): Prevent infinite loop + +2025-07-22 Steve Baird <baird@adacore.com> + + * sem_aux.ads: Declare new function Unique_Component_Name. + * sem_aux.adb: Implement new function Unique_Component_Name. + +2025-07-22 Viljar Indus <indus@adacore.com> + + * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): + Ensure the Expression_Copy always has a parent before + calling any analyze. + +2025-07-22 Steve Baird <baird@adacore.com> + + * exp_aggr.adb (Build_Record_Aggr_Code.Gen_Assign): In the case of + an aggregate component where the component type is mutably tagged + and the component value is provided by a qualified aggregate (and + qualified with a specific type), avoid incorrectly rejecting the + inner aggregate for violating the rule that the type of an + aggregate shall not be class-wide. + * exp_attr.adb: For a predefined streaming operation (i.e., Read, + Write, Input, or Output) of a class-wide type, the external name + of the tag of the value is normally written out by Output and read + in by Input. In the case of a mutably tagged type, this is instead + done in Write and Read. + * exp_ch4.adb (Expand_Composite_Equality): In the case of an + equality comparison for a type having a mutably tagged component, + we want the component comparison to compare two values of the + mutably tagged type, not two values of the corresponding + array-of-bytes-ish representation type. Even if there are no + user-defined equality functions anywhere in sight, comparing the + array values still doesn't work because undefined bits may end up + participating in the comparison (resulting in an incorrect result + of False). + * exp_put_image.adb: In the case of a class-wide type, the + predefined Image attribute includes the name of the specific type + (and a "'" character, to follow qualified expression syntax) to + indicate the tag of the value. With the introduction of mutably + tagged types, this case can now arise in the case of a component + (of either an enclosing array or an enclosing record), not just + for a top-level object. So we factor the code to do this into a + new procedure, Put_Specific_Type_Name_Qualifier, so that it can be + called from more than one place. This reorganization also involves + replacing the procedure Put_String_Exp with a new procedure, + Put_String_Exp_To_Buffer, declared in a less nested scope. For + mutably tagged components (at the source level) the component type + (at the GNAT tree level) is an array of bytes (actually a two + field record containing an array of bytes, but that's a detail). + Appropriate conversions need to be generated so that we don't end + up generating an image for an array of bytes; this is done at the + same places where Put_Specific_Type_Name_Qualifier is called + (for components) by calling Make_Mutably_Tagged_Conversion. + * exp_strm.adb (Make_Field_Attribute): Add + Make_Mutably_Tagged_Conversion call where we construct a + Selected_Component node and the corresponding component type is + the internal representation type for a mutably tagged type. + (Stream_Base_Type): Return the mutably + tagged type if given the corresponding internal representation type. + * sem_ch3.adb (Array_Type_Declaration): In the case where the + source-level component type of an array type is mutably tagged, + set the Component_Type field of the base type of the declared + array type (as opposed to that of the first subtype of the array + type) to the corresponding internal representation type. + * sem_ch4.adb (Analyze_Selected_Component): In the case of a + selected component name which references a component whose type is + the internal representation type of a mutably tagged type, + generate a conversion to the mutably tagged type. + +2025-07-21 Eric Botcazou <ebotcazou@gcc.gnu.org> + + PR ada/121184 + * styleg.adb (Check_Comment): Use consistent warning message. + +2025-07-21 Stefan Schulze Frielinghaus <stefansf@gcc.gnu.org> + + * gcc-interface/trans.cc (gnat_to_gnu): Pass null pointer to + parse_{input,output}_constraint(). + +2025-07-18 Steve Baird <baird@adacore.com> + + * sem_ch12.adb (Validate_Derived_Type_Instance): Cope with the case + where the ancestor type for a formal derived type is declared in + an earlier formal package but Get_Instance_Of does not return the + corresponding type from the corresponding actual package. + +2025-07-18 Bob Duff <duff@adacore.com> + + * tbuild.adb (Unchecked_Convert_To): Back out + change. + +2025-07-18 Marc Poulhiès <poulhies@adacore.com> + Eric Botcazou <botcazou@adacore.com> + + * exp_ch6.adb (Convert): Do not call Expand_Inlined_Call for + unsupported cases. + * inline.adb (Expand_Inlined_Call): Add assert to catch unsupported + case. + +2025-07-18 Gary Dismukes <dismukes@adacore.com> + + * einfo.ads: Document new field Overridden_Inherited_Operation and + list it as a field for the entity kinds that it applies to. + * gen_il-fields.ads (type Opt_Field_Enum): Add new literal + Overridden_Inherited_Operation to the type. + * gen_il-gen-gen_entities.adb: Add Overridden_Inherited_Operation as + a field of entities of kinds E_Enumeration_Literal and Subprogram_Kind. + * sem_ch4.adb (Is_Callable_Private_Overriding): Change name (was + Is_Private_Overriding). Replace Is_Hidden test on Overridden_Operation + with test of Is_Hidden on the new field Overridden_Inherited_Operation. + * sem_ch6.adb (New_Overloaded_Entity): Set the new field + Overridden_Inherited_Operation on an operation derived from + an interface to refer to the inherited operation of a private + extension that's overridden by the derived operation. Also set + that field in the more common cases of an explicit subprogram + that overrides, to refer to the inherited subprogram that is + overridden. (Contrary to its name, the Overridden_Operation + field of the overriding subprogram, which is also set in these + places, refers to the *parent* subprogram from which the inherited + subprogram is derived.) Also, remove a redundant Present (Alias (S)) + test in an if_statement and the dead "else" part of that statement. + +2025-07-18 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Build_Elaboration_Entity): Set ghost mode to none + before creating the elaboration entity; restore the ghost mode + afterwards. + +2025-07-18 Javier Miranda <miranda@adacore.com> + + * exp_aggr.adb (Gen_Assign): Code cleanup. + (Initialize_Component): Do not adjust the tag when the type of + the aggregate components is a mutably tagged type. + 2025-07-14 Eric Botcazou <ebotcazou@adacore.com> PR ada/121056 diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index 0b8d3f7..c780054 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -327,8 +327,23 @@ package body Accessibility is if In_Return_Value (N) or else In_Return_Context then - return Make_Level_Literal - (Subprogram_Access_Level (Current_Subprogram)); + if Present (Extra_Accessibility_Of_Result + (Current_Subprogram)) + then + -- If a function is passed an extra "level of the + -- master of the call" parameter and that function + -- returns a call to another such function (or + -- possibly to the same function, in the case of a + -- recursive call), then that parameter should be + -- "passed along". + + return New_Occurrence_Of + (Extra_Accessibility_Of_Result + (Current_Subprogram), Loc); + else + return Make_Level_Literal + (Subprogram_Access_Level (Current_Subprogram)); + end if; end if; end if; @@ -1683,16 +1698,14 @@ package body Accessibility is Condition => Check_Cond, Reason => PE_Accessibility_Check_Failed)); - -- If constant folding has happened on the condition for the - -- generated error, then warn about it being unconditional when - -- we know an error will be raised. + -- ??? Is this how we want to detect RM 6.5(5.9) violations? if Nkind (Check_Cond) = N_Identifier and then Entity (Check_Cond) = Standard_True then Error_Msg_N - ("access discriminant in return object could be a dangling" - & " reference??", Return_Stmt); + ("level of type of access discriminant value of return object" + & " is statically too deep", Return_Stmt); end if; end if; diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index d8861bf..737f151 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -92,6 +92,7 @@ package Aspects is Aspect_Default_Value, Aspect_Depends, -- GNAT Aspect_Designated_Storage_Model, -- GNAT + Aspect_Destructor, -- GNAT Aspect_Dimension, -- GNAT Aspect_Dimension_System, -- GNAT Aspect_Dispatching_Domain, @@ -259,6 +260,7 @@ package Aspects is | Aspect_Iterator_Element | Aspect_Max_Entry_Queue_Length | Aspect_No_Controlled_Parts + | Aspect_No_Task_Parts | Aspect_Real_Literal | Aspect_String_Literal | Aspect_Variable_Indexing; @@ -293,6 +295,7 @@ package Aspects is Aspect_CUDA_Global => True, Aspect_Depends => True, Aspect_Designated_Storage_Model => True, + Aspect_Destructor => True, Aspect_Dimension => True, Aspect_Dimension_System => True, Aspect_Disable_Controlled => True, @@ -447,6 +450,7 @@ package Aspects is Aspect_Default_Value => Expression, Aspect_Depends => Expression, Aspect_Designated_Storage_Model => Name, + Aspect_Destructor => Name, Aspect_Dimension => Expression, Aspect_Dimension_System => Expression, Aspect_Dispatching_Domain => Expression, @@ -551,6 +555,7 @@ package Aspects is Aspect_Default_Value => True, Aspect_Depends => False, Aspect_Designated_Storage_Model => True, + Aspect_Destructor => False, Aspect_Dimension => False, Aspect_Dimension_System => False, Aspect_Dispatching_Domain => False, @@ -726,6 +731,7 @@ package Aspects is Aspect_Default_Value => Name_Default_Value, Aspect_Depends => Name_Depends, Aspect_Designated_Storage_Model => Name_Designated_Storage_Model, + Aspect_Destructor => Name_Destructor, Aspect_Dimension => Name_Dimension, Aspect_Dimension_System => Name_Dimension_System, Aspect_Disable_Controlled => Name_Disable_Controlled, @@ -994,6 +1000,7 @@ package Aspects is Aspect_Default_Value => Always_Delay, Aspect_Default_Component_Value => Always_Delay, Aspect_Designated_Storage_Model => Always_Delay, + Aspect_Destructor => Always_Delay, Aspect_Discard_Names => Always_Delay, Aspect_Dispatching_Domain => Always_Delay, Aspect_Dynamic_Predicate => Always_Delay, diff --git a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst index f313179..ff111dd 100644 --- a/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst +++ b/gcc/ada/doc/gnat_rm/gnat_language_extensions.rst @@ -1793,3 +1793,71 @@ statement in the sequence of statements of the specified loop_statement. Note that ``continue`` is a keyword but it is not a reserved word. This is a configuration that does not exist in standard Ada. + +Destructors +----------- + +The ``Destructor`` aspect can be applied to any record type, tagged or not. +It must denote a primitive of the type that is a procedure with one parameter +of the type and of mode ``in out``: + +.. code-block:: ada + + type T is record + ... + end record with Destructor => Foo; + + procedure Foo (X : in out T); + +This is equivalent to the following code that uses ``Finalizable``: + +.. code-block:: ada + + type T is record + ... + end record with Finalizable => (Finalize => Foo); + + procedure Foo (X : in out T); + +Unlike ``Finalizable``, however, ``Destructor`` can be specified on a derived +type. And when it is, the effect of the aspect combines with the destructors of +the parent type. Take, for example: + +.. code-block:: ada + + type T1 is record + ... + end record with Destructor => Foo; + + procedure Foo (X : in out T1); + + type T2 is new T1 with Destructor => Bar; + + procedure Bar (X : in out T2); + +Here, when an object of type ``T2`` is finalized, a call to ``Bar`` +will be performed and it will be followed by a call to ``Foo``. + +The ``Destructor`` aspect comes with a legality rule: if a primitive procedure +of a type is denoted by a ``Destructor`` aspect specification, it is illegal to +override this procedure in a derived type. For example, the following is illegal: + +.. code-block:: ada + + type T1 is record + ... + end record with Destructor => Foo; + + procedure Foo (X : in out T1); + + type T2 is new T1; + + overriding + procedure Foo (X : in out T2); -- Error here + +It is possible to specify ``Destructor`` on the completion of a private type, +but there is one more restriction in that case: the denoted primitive must +be private to the enclosing package. This is necessary due to the previously +mentioned legality rule, to prevent breaking the privacy of the type when +imposing that rule on outside types that derive from the private view of the +type. diff --git a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst index 0e9162a..1f0aa03 100644 --- a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst +++ b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst @@ -333,9 +333,9 @@ must define with the following profile: "__gnat_last_chance_handler"); -The parameter is a C null-terminated string representing a message to be -associated with the exception (typically the source location of the raise -statement generated by the compiler). The Line parameter when nonzero +The ``Source_Location`` parameter is a C null-terminated string representing a +message to be associated with the exception (typically the source location of +the raise statement generated by the compiler). The Line parameter when nonzero represents the line number in the source program where the raise occurs. No_Exception_Propagation diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index ba79fe4..916d9c6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1279,9 +1279,10 @@ package Einfo is -- that represents an activation record pointer is an extra formal. -- Extra_Formals --- Applies to subprograms, subprogram types, entries, and entry --- families. Returns first extra formal of the subprogram or entry. --- Returns Empty if there are no extra formals. +-- Applies to subprograms, subprogram types, entries, and entry families. +-- Returns the first extra formal of the subprogram or entry. An entity +-- has no extra formals when this attribute is Empty, and its attribute +-- Extra_Formals_Known is True. -- Finalization_Collection [root type only] -- Defined in access-to-controlled or access-to-class-wide types. The @@ -1594,6 +1595,11 @@ package Einfo is -- set, signalling that Freeze.Inherit_Delayed_Rep_Aspects must be called -- at the freeze point of the derived type. +-- Has_Destructor +-- Defined in all type and subtype entities. Set only for record type +-- entities for which at least one ancestor has the Destructor aspect +-- specified. + -- Has_DIC (synthesized) -- Defined in all type entities. Set for a private type and its full view -- when the type is subject to pragma Default_Initial_Condition (DIC), or @@ -1640,11 +1646,6 @@ package Einfo is -- that this does not imply a representation with holes, since the rep -- clause may merely confirm the default 0..N representation. --- Has_First_Controlling_Parameter_Aspect --- Defined in tagged types, concurrent types and concurrent record types. --- Set to indicate that the type has a First_Controlling_Parameter of --- True (whether by an aspect_specification, a pragma, or inheritance). - -- Has_Exit -- Defined in loop entities. Set if the loop contains an exit statement. @@ -1654,6 +1655,12 @@ package Einfo is -- flag prevents double expansion of a contract when a construct is -- rewritten into something else and subsequently reanalyzed/expanded. +-- Has_First_Controlling_Parameter_Aspect +-- Defined in tagged types, concurrent types, and concurrent record +-- types. Set to indicate that the type has a First_Controlling_Parameter +-- of True (whether by an aspect_specification, a pragma, or +-- inheritance). + -- Has_Foreign_Convention (synthesized) -- Applies to all entities. Determines if the Convention for the entity -- is a foreign convention, i.e. non-native: other than Convention_Ada, @@ -1668,6 +1675,12 @@ package Einfo is -- the instance will conflict with the linear elaboration of front-end -- inlining. +-- Extra_Formals_Known +-- Defined in subprograms, subprogram types, entries, and entry families. +-- Set when the extra formals have been determined. An entity has no +-- extra formals when this attribute is True, and its attribute +-- Extra_Formals is Empty. + -- Has_Fully_Qualified_Name -- Defined in all entities. Set if the name in the Chars field has been -- replaced by the fully qualified name, as used for debug output. See @@ -2515,11 +2528,12 @@ package Einfo is -- Is_Controlled_Active [base type only] -- Defined in all type entities. Indicates that the type is controlled, --- i.e. has been declared with the Finalizable aspect or has inherited --- the Finalizable aspect from an ancestor. Can only be set for record --- types, tagged or untagged. System.Finalization_Root.Root_Controlled --- is an example of the former case while Ada.Finalization.Controlled --- and Ada.Finalization.Limited_Controlled are examples of the latter. +-- i.e. has been declared with the Finalizable or the Destructor aspect +-- or has inherited the aspect from an ancestor. Can only be set for +-- record types, tagged or untagged. +-- System.Finalization_Root.Root_Controlled is an example of the former +-- case while Ada.Finalization.Controlled and +-- Ada.Finalization.Limited_Controlled are examples of the latter. -- Is_Controlled (synth) [base type only] -- Defined in all type entities. Set if Is_Controlled_Active is set for @@ -2545,6 +2559,10 @@ package Einfo is -- Defined in all entities. True if the entity is type System.Address, -- or (recursively) a subtype or derived type of System.Address. +-- Is_Destructor +-- Defined in procedure entities. True if the procedure is denoted by the +-- Destructor aspect on some type. + -- Is_DIC_Procedure -- Defined in functions and procedures. Set for a generated procedure -- which verifies the assumption of pragma Default_Initial_Condition at @@ -2779,6 +2797,10 @@ package Einfo is -- identifiers in standard library packages, and to implement the -- restriction No_Implementation_Identifiers. +-- Is_Implicit_Full_View +-- Defined in types. Set on types that the compiler generates to act as +-- full views of types that are derivations of private types. + -- Is_Imported -- Defined in all entities. Set if the entity is imported. For now we -- only allow the import of exceptions, functions, procedures, packages, @@ -3940,9 +3962,21 @@ package Einfo is -- Defined in constants and variables. Set if there is an address clause -- that causes the entity to overlay a constant object. +-- Overridden_Inherited_Operation +-- Defined in subprograms and enumeration literals. When set on a +-- subprogram S, indicates an inherited subprogram that S overrides. +-- In the case of a privately declared explicit subprogram E that +-- overrides a private inherited subprogram, and the inherited +-- subprogram itself overrides another inherited subprogram declared +-- for a private extension, the field on E will reference the subprogram +-- inherited by the private extension. This field is used for properly +-- handling visibility for such privately declared subprograms. This +-- field is always Empty for enumeration literal entities. + -- Overridden_Operation -- Defined in subprograms. For overriding operations, points to the --- user-defined parent subprogram that is being overridden. +-- user-defined parent subprogram from which the inherited subprogram +-- that is being overridden is derived. -- Package_Instantiation -- Defined in packages and generic packages. When defined, this field @@ -5381,11 +5415,12 @@ package Einfo is -- Scope_Depth_Value -- Protection_Object (protected kind) -- Contract_Wrapper - -- Extra_Formals -- Contract -- SPARK_Pragma (protected kind) -- Default_Expressions_Processed -- Entry_Accepted + -- Extra_Formals + -- Extra_Formals_Known -- Has_Yield_Aspect -- Has_Expanded_Contract -- Ignore_SPARK_Mode_Pragmas @@ -5413,6 +5448,7 @@ package Einfo is -- Enumeration_Pos -- Enumeration_Rep -- Alias + -- Overridden_Inherited_Operation -- Enumeration_Rep_Expr -- Interface_Name $$$ -- Renamed_Object $$$ @@ -5502,9 +5538,11 @@ package Einfo is -- Subps_Index (non-generic case only) -- Interface_Alias -- LSP_Subprogram (non-generic case only) + -- Overridden_Inherited_Operation -- Overridden_Operation -- Wrapped_Entity (non-generic case only) -- Extra_Formals + -- Extra_Formals_Known (non-generic case only) -- Anonymous_Collections (non-generic case only) -- Corresponding_Equality (implicit /= only) -- Thunk_Entity (thunk case only) @@ -5705,9 +5743,12 @@ package Einfo is -- Extra_Accessibility_Of_Result -- Last_Entity -- Subps_Index + -- Overridden_Inherited_Operation -- Overridden_Operation -- Linker_Section_Pragma -- Contract + -- Extra_Formals + -- Extra_Formals_Known -- Import_Pragma -- LSP_Subprogram -- SPARK_Pragma @@ -5858,9 +5899,11 @@ package Einfo is -- Subps_Index (non-generic case only) -- Interface_Alias -- LSP_Subprogram (non-generic case only) + -- Overridden_Inherited_Operation -- Overridden_Operation (never for init proc) -- Wrapped_Entity (non-generic case only) -- Extra_Formals + -- Extra_Formals_Known (non-generic case only) -- Anonymous_Collections (non-generic case only) -- Static_Initialization (init_proc only) -- Thunk_Entity (thunk case only) @@ -5899,6 +5942,7 @@ package Einfo is -- Is_Class_Wide_Wrapper -- Is_Constructor -- Is_CUDA_Kernel + -- Is_Destructor (non-generic case only) -- Is_DIC_Procedure (non-generic case only) -- Is_Elaboration_Checks_OK_Id -- Is_Elaboration_Warnings_OK_Id @@ -6088,6 +6132,7 @@ package Einfo is -- Last_Entity -- Scope_Depth_Value -- Extra_Formals + -- Extra_Formals_Known -- Anonymous_Collections -- Contract -- SPARK_Pragma @@ -6101,6 +6146,7 @@ package Einfo is -- Extra_Accessibility_Of_Result -- Directly_Designated_Type -- Extra_Formals + -- Extra_Formals_Known -- Access_Subprogram_Wrapper -- First_Formal (synth) -- First_Formal_With_Extras (synth) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 9ff69ec..cd98369 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -1422,8 +1422,11 @@ package body Exp_Aggr is elsif Is_Mutably_Tagged_Type (Comp_Typ) and then Nkind (Expr) = N_Qualified_Expression then - Analyze_And_Resolve (Expr_Q, Etype (Expr)); + -- Avoid class-wide expected type for aggregate + -- (which would be rejected as illegal) + -- if the aggregate is explicitly qualified. + Analyze_And_Resolve (Expr_Q, Etype (Expr)); else Analyze_And_Resolve (Expr_Q, Comp_Typ); end if; @@ -1457,54 +1460,12 @@ package body Exp_Aggr is end if; if Present (Expr) then - - -- For mutably tagged abstract class-wide types, we rely on the - -- type of the initializing expression to initialize the tag of - -- each array component. - - -- Generate: - -- expr_type!(Indexed_Comp) := expr; - -- expr_type!(Indexed_Comp)._tag := expr_type'Tag; - - if Is_Mutably_Tagged_Type (Comp_Typ) - and then Is_Abstract_Type (Root_Type (Comp_Typ)) - then - declare - Expr_Type : Entity_Id; - - begin - if Nkind (Expr) in N_Has_Etype - and then Present (Etype (Expr)) - then - Expr_Type := Etype (Expr); - - elsif Nkind (Expr) = N_Qualified_Expression then - Analyze (Subtype_Mark (Expr)); - Expr_Type := Etype (Subtype_Mark (Expr)); - - -- Unsupported case - - else - pragma Assert (False); - raise Program_Error; - end if; - - Initialize_Component - (N => N, - Comp => Unchecked_Convert_To (Expr_Type, - Indexed_Comp), - Comp_Typ => Expr_Type, - Init_Expr => Expr, - Stmts => Stmts); - end; - else - Initialize_Component - (N => N, - Comp => Indexed_Comp, - Comp_Typ => Comp_Typ, - Init_Expr => Expr, - Stmts => Stmts); - end if; + Initialize_Component + (N => N, + Comp => Indexed_Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Expr, + Stmts => Stmts); -- Ada 2005 (AI-287): In case of default initialized component, call -- the initialization subprogram associated with the component type. @@ -1519,10 +1480,10 @@ package body Exp_Aggr is else -- For mutably tagged class-wide types, default initialization is - -- performed by the init procedure of their root type. + -- performed by the init procedure of their specific type. if Is_Mutably_Tagged_Type (Comp_Typ) then - Comp_Typ := Root_Type (Comp_Typ); + Comp_Typ := Find_Specific_Type (Comp_Typ); end if; if Present (Base_Init_Proc (Comp_Typ)) then @@ -4388,6 +4349,7 @@ package body Exp_Aggr is and then Is_Limited_Type (Typ) then Target_Expr := New_Copy_Tree (Name (Parent_Node)); + Ensure_Defined (Typ, Parent_Node); Insert_Actions (Parent_Node, Build_Record_Aggr_Code (N, Typ, Target_Expr)); Rewrite (Parent_Node, Make_Null_Statement (Loc)); @@ -4413,6 +4375,7 @@ package body Exp_Aggr is if Nkind (N) in N_Aggregate | N_Extension_Aggregate then Target_Expr := New_Copy_Tree (Lhs); + Ensure_Defined (Typ, Parent_Node); Insert_Actions (Parent_Node, Build_Record_Aggr_Code (N, Typ, Target_Expr)); Rewrite (Parent_Node, Make_Null_Statement (Loc)); @@ -6771,6 +6734,7 @@ package body Exp_Aggr is function Build_Size_Expr (Comp : Node_Id) return Node_Id is Lo, Hi : Node_Id; It : Node_Id; + It_Subt : Entity_Id; Siz_Exp : Node_Id := Empty; Choice : Node_Id; Temp_Siz_Exp : Node_Id; @@ -6845,20 +6809,22 @@ package body Exp_Aggr is elsif Nkind (Comp) = N_Iterated_Component_Association then if Present (Iterator_Specification (Comp)) then - -- If the static size of the iterable object is known, + -- If the size of the iterable object can be determined, -- attempt to return it. It := Name (Iterator_Specification (Comp)); Preanalyze (It); - -- Handle the simplest cases for now where It denotes an array - -- object. + It_Subt := Etype (It); + + -- Handle the simplest cases for now, where It denotes an array + -- object or a container object. if Nkind (It) in N_Identifier - and then Ekind (Etype (It)) = E_Array_Subtype + and then Ekind (It_Subt) = E_Array_Subtype then declare - Idx_N : Node_Id := First_Index (Etype (It)); + Idx_N : Node_Id := First_Index (It_Subt); Siz_Exp : Node_Id := Empty; begin while Present (Idx_N) loop @@ -6892,6 +6858,96 @@ package body Exp_Aggr is return Siz_Exp; end; + + -- Case of iterating over a container object. Note that this + -- must be a simple object, and not something like a function + -- call (which might have side effects, and we wouldn't want + -- it to be evaluated more than once). We take advantage of + -- RM22 4.3.5(40/5), which allows implementation-defined + -- behavior for the parameter passed to the Empty function, + -- and here use the container Length function when available. + -- Class-wide objects are also excluded, since those would + -- lead to dispatching, which could call a user-defined + -- overriding of Length that might have arbitrary effects. + + elsif Is_Entity_Name (It) + and then Is_Object (Entity (It)) + and then Ekind (It_Subt) in Record_Kind + and then not Is_Class_Wide_Type (It_Subt) + then + declare + Aggr_Base : constant Entity_Id := Base_Type (Typ); + It_Base : constant Entity_Id := Base_Type (It_Subt); + Empty_Formal : constant Entity_Id := + First_Formal (Entity (Empty_Subp)); + Length_Subp : Entity_Id; + Param_List : List_Id; + + begin + -- We only determine a nondefault capacity in the case + -- of containers of predefined container types, which + -- generally have a Length function. User-defined + -- containers don't necessarily have such a function, + -- or it may be named differently, or it may have + -- the wrong semantics. The base subtypes are tested, + -- since their Sloc will refer to the original container + -- generics in the predefined library, even though the + -- types are declared in a package instantiation in some + -- other unit. Also, this is only done when Empty_Subp + -- has a formal parameter (generally named Capacity), + -- and not in the case of a parameterless Empty function. + -- Finally, we test for the container aggregate's type + -- having a first discriminant with the name Capacity, + -- since determining capacity via Length is only sensible + -- for container types with that discriminant (bounded + -- containers). + + if Present (Empty_Formal) + and then In_Predefined_Unit (It_Base) + and then In_Predefined_Unit (Aggr_Base) + and then Has_Discriminants (Aggr_Base) + and then + Get_Name_String + (Chars (First_Discriminant (Aggr_Base))) + = "capacity" + then + -- Look for the container type's Length function in + -- the package where it's defined. + + Push_Scope (Scope (It_Base)); + + Length_Subp := Current_Entity_In_Scope (Name_Length); + + Pop_Scope; + + -- If we found a Length function that has a single + -- parameter of the iterator object's container type, + -- then expand a call to that, passing the object, + -- and return that call, which will be used as the + -- "size" of the current element association of the + -- bounded container aggregate. + + if Present (Length_Subp) + and then Ekind (Length_Subp) = E_Function + and then + Present (First_Entity (Length_Subp)) + and then + No (Next_Entity (First_Entity (Length_Subp))) + and then + Base_Type + (Etype (First_Entity (Length_Subp))) = It_Base + then + Param_List := + New_List (New_Occurrence_Of (Entity (It), Loc)); + + return + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Length_Subp, Loc), + Parameter_Associations => Param_List); + end if; + end if; + end; end if; return Empty; @@ -8864,7 +8920,15 @@ package body Exp_Aggr is else Set_No_Ctrl_Actions (Init_Stmt); - if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then + if Tagged_Type_Expansion + and then Is_Tagged_Type (Comp_Typ) + + -- Cannot adjust the tag when the expected type of the component is + -- a mutably tagged (and therefore class-wide) type; each component + -- of the aggregate has the tag of its initializing expression. + + and then not Is_Mutably_Tagged_Type (Comp_Typ) + then declare Typ : Entity_Id := Underlying_Type (Comp_Typ); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 4f9f16c..810248d 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1915,6 +1915,15 @@ package body Exp_Attr is -- call to the appropriate TSS procedure. Pname is the entity for the -- procedure to call. + procedure Read_Controlling_Tag + (P_Type : Entity_Id; Cntrl : out Node_Id); + -- Read the external tag from the stream and use it to construct the + -- controlling operand for a dispatching call. + + procedure Write_Controlling_Tag (P_Type : Entity_Id); + -- Write the external tag of the given attribute prefix type to + -- the stream. Also perform the accompanying accessibility check. + ------------------------------------- -- Build_And_Insert_Type_Attr_Subp -- ------------------------------------- @@ -2175,6 +2184,153 @@ package body Exp_Attr is Analyze (N); end Rewrite_Attribute_Proc_Call; + -------------------------- + -- Read_Controlling_Tag -- + -------------------------- + + procedure Read_Controlling_Tag + (P_Type : Entity_Id; Cntrl : out Node_Id) + is + Strm : constant Node_Id := First (Exprs); + Expr : Node_Id; -- call to Descendant_Tag + Get_Tag : Node_Id; -- expression to read the 'Tag + + begin + -- Read the internal tag (RM 13.13.2(34)) and use it to + -- initialize a dummy tag value. We used to unconditionally + -- generate: + -- + -- Descendant_Tag (String'Input (Strm), P_Type); + -- + -- which turns into a call to String_Input_Blk_IO. However, + -- if the input is malformed, that could try to read an + -- enormous String, causing chaos. So instead we call + -- String_Input_Tag, which does the same thing as + -- String_Input_Blk_IO, except that if the String is + -- absurdly long, it raises an exception. + -- + -- However, if the No_Stream_Optimizations restriction + -- is active, we disable this unnecessary attempt at + -- robustness; we really need to read the string + -- character-by-character. + -- + -- This value is used only to provide a controlling + -- argument for the eventual _Input call. Descendant_Tag is + -- called rather than Internal_Tag to ensure that we have a + -- tag for a type that is descended from the prefix type and + -- declared at the same accessibility level (the exception + -- Tag_Error will be raised otherwise). The level check is + -- required for Ada 2005 because tagged types can be + -- extended in nested scopes (AI-344). + + -- Note: we used to generate an explicit declaration of a + -- constant Ada.Tags.Tag object, and use an occurrence of + -- this constant in Cntrl, but this caused a secondary stack + -- leak. + + if Restriction_Active (No_Stream_Optimizations) then + Get_Tag := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_String, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)))); + else + Get_Tag := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_String_Input_Tag), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)))); + end if; + + Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), + Parameter_Associations => New_List ( + Get_Tag, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (P_Type, Loc), + Attribute_Name => Name_Tag))); + + Set_Etype (Expr, RTE (RE_Tag)); + + -- Construct a controlling operand for a dispatching call. + + Cntrl := Unchecked_Convert_To (P_Type, Expr); + Set_Etype (Cntrl, P_Type); + Set_Parent (Cntrl, N); + end Read_Controlling_Tag; + + ---------------------------- + -- Write_Controlling_Tag -- + ---------------------------- + + procedure Write_Controlling_Tag (P_Type : Entity_Id) is + Strm : constant Node_Id := First (Exprs); + Item : constant Node_Id := Next (Strm); + begin + -- Ada 2005 (AI-344): Check that the accessibility level + -- of the type of the output object is not deeper than + -- that of the attribute's prefix type. + + -- if Get_Access_Level (Item'Tag) + -- /= Get_Access_Level (P_Type'Tag) + -- then + -- raise Tag_Error; + -- end if; + + -- String'Output (Strm, External_Tag (Item'Tag)); + + -- We cannot figure out a practical way to implement this + -- accessibility check on virtual machines, so we omit it. + + if Ada_Version >= Ada_2005 + and then Tagged_Type_Expansion + then + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Build_Get_Access_Level (Loc, + Make_Attribute_Reference (Loc, + Prefix => + Relocate_Node ( + Duplicate_Subexpr (Item, + Name_Req => True)), + Attribute_Name => Name_Tag)), + + Right_Opnd => + Make_Integer_Literal (Loc, + Type_Access_Level (P_Type))), + + Then_Statements => + New_List (Make_Raise_Statement (Loc, + New_Occurrence_Of ( + RTE (RE_Tag_Error), Loc))))); + end if; + + Insert_Action (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_String, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_External_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Relocate_Node + (Duplicate_Subexpr (Item, Name_Req => True)), + Attribute_Name => Name_Tag)))))); + end Write_Controlling_Tag; + Typ : constant Entity_Id := Etype (N); Btyp : constant Entity_Id := Base_Type (Typ); Ptyp : constant Entity_Id := Etype (Pref); @@ -4487,94 +4643,57 @@ package body Exp_Attr is elsif Is_Class_Wide_Type (P_Type) then - -- No need to do anything else compiling under restriction - -- No_Dispatching_Calls. During the semantic analysis we - -- already notified such violation. + if Is_Mutably_Tagged_Type (P_Type) then - if Restriction_Active (No_Dispatching_Calls) then - return; - end if; + -- In mutably tagged case, rewrite + -- T'Class'Input (Strm) + -- as (roughly) + -- declare + -- Result : T'Class; + -- T'Class'Read (Strm, Result); + -- begin + -- Result; + -- end; - declare - Rtyp : constant Entity_Id := Root_Type (P_Type); + declare + Result_Temp : constant Entity_Id := + Make_Temporary (Loc, 'I'); - Expr : Node_Id; -- call to Descendant_Tag - Get_Tag : Node_Id; -- expression to read the 'Tag + -- Gets default initialization + Result_Temp_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Temp, + Object_Definition => + New_Occurrence_Of (P_Type, Loc)); - begin - -- Read the internal tag (RM 13.13.2(34)) and use it to - -- initialize a dummy tag value. We used to unconditionally - -- generate: - -- - -- Descendant_Tag (String'Input (Strm), P_Type); - -- - -- which turns into a call to String_Input_Blk_IO. However, - -- if the input is malformed, that could try to read an - -- enormous String, causing chaos. So instead we call - -- String_Input_Tag, which does the same thing as - -- String_Input_Blk_IO, except that if the String is - -- absurdly long, it raises an exception. - -- - -- However, if the No_Stream_Optimizations restriction - -- is active, we disable this unnecessary attempt at - -- robustness; we really need to read the string - -- character-by-character. - -- - -- This value is used only to provide a controlling - -- argument for the eventual _Input call. Descendant_Tag is - -- called rather than Internal_Tag to ensure that we have a - -- tag for a type that is descended from the prefix type and - -- declared at the same accessibility level (the exception - -- Tag_Error will be raised otherwise). The level check is - -- required for Ada 2005 because tagged types can be - -- extended in nested scopes (AI-344). - - -- Note: we used to generate an explicit declaration of a - -- constant Ada.Tags.Tag object, and use an occurrence of - -- this constant in Cntrl, but this caused a secondary stack - -- leak. - - if Restriction_Active (No_Stream_Optimizations) then - Get_Tag := - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Standard_String, Loc), - Attribute_Name => Name_Input, - Expressions => New_List ( - Relocate_Node (Duplicate_Subexpr (Strm)))); - else - Get_Tag := - Make_Function_Call (Loc, - Name => - New_Occurrence_Of - (RTE (RE_String_Input_Tag), Loc), - Parameter_Associations => New_List ( - Relocate_Node (Duplicate_Subexpr (Strm)))); - end if; + function Result_Temp_Name return Node_Id is + (New_Occurrence_Of (Result_Temp, Loc)); - Expr := - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), - Parameter_Associations => New_List ( - Get_Tag, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (P_Type, Loc), - Attribute_Name => Name_Tag))); + Actions : constant List_Id := New_List ( + Result_Temp_Decl, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (P_Type, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Relocate_Node (Strm), Result_Temp_Name))); + begin + Rewrite (N, Make_Expression_With_Actions (Loc, + Actions, Result_Temp_Name)); + Analyze_And_Resolve (N, P_Type); + return; + end; + end if; - Set_Etype (Expr, RTE (RE_Tag)); + -- No need to do anything else compiling under restriction + -- No_Dispatching_Calls. During the semantic analysis we + -- already notified such violation. - -- Now we need to get the entity for the call, and construct - -- a function call node, where we preset a reference to Dnn - -- as the controlling argument (doing an unchecked convert - -- to the class-wide tagged type to make it look like a real - -- tagged object). + if Restriction_Active (No_Dispatching_Calls) then + return; + end if; - Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input); - Cntrl := Unchecked_Convert_To (P_Type, Expr); - Set_Etype (Cntrl, P_Type); - Set_Parent (Cntrl, N); - end; + Read_Controlling_Tag (P_Type, Cntrl); + Fname := Find_Prim_Op (Root_Type (P_Type), TSS_Stream_Input); -- For tagged types, use the primitive Input function @@ -5957,6 +6076,14 @@ package body Exp_Attr is Attr_Ref => N); end; + -- In the mutably tagged case, T'Class'Output calls T'Class'Write; + -- T'Write will take care of writing out the external tag. + + elsif Is_Mutably_Tagged_Type (P_Type) then + Set_Attribute_Name (N, Name_Write); + Analyze (N); + return; + -- Class-wide case, first output external tag, then dispatch -- to the appropriate primitive Output function (RM 13.13.2(31)). @@ -5970,68 +6097,7 @@ package body Exp_Attr is return; end if; - Tag_Write : declare - Strm : constant Node_Id := First (Exprs); - Item : constant Node_Id := Next (Strm); - - begin - -- Ada 2005 (AI-344): Check that the accessibility level - -- of the type of the output object is not deeper than - -- that of the attribute's prefix type. - - -- if Get_Access_Level (Item'Tag) - -- /= Get_Access_Level (P_Type'Tag) - -- then - -- raise Tag_Error; - -- end if; - - -- String'Output (Strm, External_Tag (Item'Tag)); - - -- We cannot figure out a practical way to implement this - -- accessibility check on virtual machines, so we omit it. - - if Ada_Version >= Ada_2005 - and then Tagged_Type_Expansion - then - Insert_Action (N, - Make_Implicit_If_Statement (N, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => - Build_Get_Access_Level (Loc, - Make_Attribute_Reference (Loc, - Prefix => - Relocate_Node ( - Duplicate_Subexpr (Item, - Name_Req => True)), - Attribute_Name => Name_Tag)), - - Right_Opnd => - Make_Integer_Literal (Loc, - Type_Access_Level (P_Type))), - - Then_Statements => - New_List (Make_Raise_Statement (Loc, - New_Occurrence_Of ( - RTE (RE_Tag_Error), Loc))))); - end if; - - Insert_Action (N, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Standard_String, Loc), - Attribute_Name => Name_Output, - Expressions => New_List ( - Relocate_Node (Duplicate_Subexpr (Strm)), - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_External_Tag), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - Relocate_Node - (Duplicate_Subexpr (Item, Name_Req => True)), - Attribute_Name => Name_Tag)))))); - end Tag_Write; + Write_Controlling_Tag (P_Type); Pname := Find_Prim_Op (U_Type, TSS_Stream_Output); @@ -6793,6 +6859,7 @@ package body Exp_Attr is P_Type : constant Entity_Id := Entity (Pref); B_Type : constant Entity_Id := Base_Type (P_Type); U_Type : constant Entity_Id := Underlying_Type (P_Type); + Cntrl : Node_Id := Empty; -- nonempty only if P_Type mutably tagged Pname : Entity_Id; Decl : Node_Id; Prag : Node_Id; @@ -6941,6 +7008,11 @@ package body Exp_Attr is -- this will dispatch in the class-wide case which is what we want elsif Is_Tagged_Type (U_Type) then + + if Is_Mutably_Tagged_Type (U_Type) then + Read_Controlling_Tag (P_Type, Cntrl); + end if; + Pname := Find_Prim_Op (U_Type, TSS_Stream_Read); -- All other record type cases, including protected records. The @@ -7001,6 +7073,46 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); + if Present (Cntrl) then + pragma Assert (Is_Mutably_Tagged_Type (U_Type)); + pragma Assert (Nkind (N) = N_Procedure_Call_Statement); + + -- Assign the Tag value that was read from the stream + -- to the tag of the out-mode actual parameter so that + -- we dispatch correctly. This isn't quite right. + -- We should assign a complete object (not just + -- the tag), but that would require a dispatching call to + -- perform default initialization of the source object and + -- dispatching default init calls are currently not supported. + + declare + function Select_Tag (Prefix : Node_Id) return Node_Id is + (Make_Selected_Component (Loc, + Prefix => Prefix, + Selector_Name => + New_Occurrence_Of (First_Tag_Component + (Etype (Prefix)), Loc))); + + Controlling_Actual : constant Node_Id := + Next (First (Parameter_Associations (N))); + + pragma Assert (Is_Controlling_Actual (Controlling_Actual)); + + Assign_Tag : Node_Id; + begin + Remove_Side_Effects (Controlling_Actual, Name_Req => True); + + Assign_Tag := + Make_Assignment_Statement (Loc, + Name => + Select_Tag (New_Copy_Tree (Controlling_Actual)), + Expression => Select_Tag (Cntrl)); + + Insert_Before (Before => N, Node => Assign_Tag); + Analyze (Assign_Tag); + end; + end if; + if not Is_Tagged_Type (P_Type) then Cached_Attribute_Ops.Read_Map.Set (U_Type, Pname); end if; @@ -8611,6 +8723,14 @@ package body Exp_Attr is -- this will dispatch in the class-wide case which is what we want elsif Is_Tagged_Type (U_Type) then + + -- If T'Class is mutably tagged, then the external tag + -- is written out by T'Class'Write, not by T'Class'Output. + + if Is_Mutably_Tagged_Type (U_Type) then + Write_Controlling_Tag (P_Type); + end if; + Pname := Find_Prim_Op (U_Type, TSS_Stream_Write); -- All other record type cases, including protected records. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 5a47a5a..6cf7c9c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -942,10 +942,11 @@ package body Exp_Ch3 is Make_Handled_Sequence_Of_Statements (Loc, Statements => Body_Stmts))); - Mutate_Ekind (Proc_Id, E_Procedure); - Set_Is_Public (Proc_Id, Is_Public (A_Type)); - Set_Is_Internal (Proc_Id); - Set_Has_Completion (Proc_Id); + Mutate_Ekind (Proc_Id, E_Procedure); + Set_Is_Public (Proc_Id, Is_Public (A_Type)); + Set_Is_Internal (Proc_Id); + Set_Has_Completion (Proc_Id); + Freeze_Extra_Formals (Proc_Id); if not Debug_Generated_Code then Set_Debug_Info_Off (Proc_Id); @@ -3204,6 +3205,7 @@ package body Exp_Ch3 is end if; Set_Parameter_Specifications (Proc_Spec_Node, Parameters); + Freeze_Extra_Formals (Proc_Id); Set_Specification (Body_Node, Proc_Spec_Node); Set_Declarations (Body_Node, Decls); @@ -6496,7 +6498,7 @@ package body Exp_Ch3 is end; end if; - if Has_Controlled_Component (Typ) then + if Has_Controlled_Component (Typ) or else Has_Destructor (Typ) then Build_Controlling_Procs (Typ); end if; @@ -6570,17 +6572,16 @@ package body Exp_Ch3 is -- procedure, because a self-referential type might call one of these -- primitives in the body of the init_proc itself. -- - -- This is not needed: - -- 1) If expansion is disabled, because extra formals are only added - -- when we are generating code. + -- This is not needed when expansion is disabled, because extra formals + -- are only added when we are generating code. -- - -- 2) For types with foreign convention since primitives with foreign - -- convention don't have extra formals and AI95-117 requires that - -- all primitives of a tagged type inherit the convention. + -- Notice that for tagged types with foreign convention this is also + -- required because (although primitives with foreign convention don't + -- have extra formals), a tagged type with foreign convention may have + -- primitives with convention Ada. if Expander_Active and then Is_Tagged_Type (Typ) - and then not Has_Foreign_Convention (Typ) then declare Elmt : Elmt_Id; @@ -7500,6 +7501,12 @@ package body Exp_Ch3 is Apply_CW_Accessibility_Check (Expr, Func_Id); end if; + if Has_Anonymous_Access_Discriminant (Etype (Expr)) then + -- Check that access discrims do not designate entities + -- that the function result could outlive. + Apply_Access_Discrims_Accessibility_Check (Expr, Func_Id); + end if; + Alloc_Expr := New_Copy_Tree (Expr); if Etype (Alloc_Expr) /= Alloc_Typ then @@ -9058,6 +9065,10 @@ package body Exp_Ch3 is if Is_Class_Wide_Type (Etype (Func_Id)) then Apply_CW_Accessibility_Check (Expr_Q, Func_Id); end if; + + -- ??? Usually calls to Apply_CW_Accessibility_Check and to + -- Apply_Access_Discrims_Accessibility_Check come in pairs. + -- Do we need a (conditional) call here to A_A_D_A_C ? end; end if; @@ -12845,25 +12856,27 @@ package body Exp_Ch3 is Append_To (Res, Decl); end if; - Fin_Call := Empty; - Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); + if not Has_Destructor (Tag_Typ) then + Fin_Call := Empty; + Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); - if Is_Controlled (Tag_Typ) then - Fin_Call := - Make_Final_Call - (Obj_Ref => Make_Identifier (Loc, Name_V), - Typ => Tag_Typ); - end if; + if Is_Controlled (Tag_Typ) then + Fin_Call := + Make_Final_Call + (Obj_Ref => Make_Identifier (Loc, Name_V), Typ => Tag_Typ); + end if; - if No (Fin_Call) then - Fin_Call := Make_Null_Statement (Loc); - end if; + if No (Fin_Call) then + Fin_Call := Make_Null_Statement (Loc); + end if; - Set_Handled_Statement_Sequence (Decl, - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Fin_Call))); + Set_Handled_Statement_Sequence + (Decl, + Make_Handled_Sequence_Of_Statements + (Loc, Statements => New_List (Fin_Call))); - Append_To (Res, Decl); + Append_To (Res, Decl); + end if; end if; return Res; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 76386fc..43c94f3 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2354,6 +2354,7 @@ package body Exp_Ch4 is Rhs : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Nod); + CW_Comp : Boolean := False; Full_Type : Entity_Id; Eq_Op : Entity_Id; @@ -2383,10 +2384,17 @@ package body Exp_Ch4 is Full_Type := Underlying_Type (Full_Type); end if; + if Is_Class_Wide_Equivalent_Type (Full_Type) then + CW_Comp := True; + Full_Type := + Get_Corresponding_Mutably_Tagged_Type_If_Present (Full_Type); + pragma Assert (Is_Tagged_Type (Full_Type)); + end if; + -- Case of tagged record types if Is_Tagged_Type (Full_Type) then - Eq_Op := Find_Primitive_Eq (Comp_Type); + Eq_Op := Find_Primitive_Eq (if CW_Comp then Full_Type else Comp_Type); pragma Assert (Present (Eq_Op)); return diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c24c8c6..eb7422c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -734,6 +734,258 @@ package body Exp_Ch6 is Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual); end Add_Task_Actuals_To_Build_In_Place_Call; + ---------------------------------------------- + -- Apply_Access_Discrims_Accesibility_Check -- + ---------------------------------------------- + + procedure Apply_Access_Discrims_Accessibility_Check + (Exp : Node_Id; Func : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Exp); + + -- Some of the code here in this procedure may need to be factored + -- out at some point because it seems like some of the same + -- functionality would be needed for accessibility checking of a + -- return statement when the function result type is an anonymous + -- access type (as opposed to a type that has an anonymous access + -- discriminant). + -- + -- Another case that is not addressed today is the case where + -- we need to check an access discriminant subcomponent of the + -- function result other than a discriminant of the function result. + -- This can only happen if the function result type has an unconstrained + -- subcomponent subtype that has an access discriminant (which implies + -- that the function result type must be limited). + -- + -- A further corner case of that corner case arises if the limited + -- function result type is class-wide and it is not known statically + -- that this access-discriminant-bearing subcomponent exists. The + -- easiest way to address this properly would probably involve adding + -- a new compiler-generated dispatching procedure; a dispatching call + -- could then be used to perform the check in a context where we know + -- statically the specific type of the function result. Finding a + -- less important unimplemented case would be challenging. + + function Constraint_Bearing_Subtype_If_Any + (Exp : Node_Id) return Node_Id; + -- If we can locate a constrained subtype whose constraint applies + -- to Exp, then return that. Otherwise, return Etype (Exp). + + function Discr_Expression + (Typ : Entity_Id; Discr_Index : Positive) return Node_Id; + -- Typ is a constrained discriminated subtype. + -- Return the constraint expression for the indexed discriminant. + + function Has_Level_Tied_To_Explicitly_Aliased_Param + (Constraint_Exp : Node_Id) return Boolean; + -- Constraint_Exp is the value given for an access discriminant + -- in a discriminant constraint for Exp. Return True iff the + -- accessibility of the type of that discriminant of Exp is the level + -- of an explicitly aliased parameter of Func. If true, this indicates + -- that no check should be performed for this discriminant. + + --------------------------------------- + -- Constraint_Bearing_Subtype_If_Any -- + --------------------------------------- + + function Constraint_Bearing_Subtype_If_Any + (Exp : Node_Id) return Entity_Id + is + Result : Entity_Id := Etype (Exp); + begin + if Is_Constrained (Result) then + return Result; + end if; + + -- Look through expansion-generated levels of indirection + -- to find a constrained subtype. Yuck. This comes up in + -- some cases when the unexpanded source returns an aggregate. + + if Nkind (Exp) = N_Explicit_Dereference + and then Nkind (Prefix (Exp)) = N_Identifier + and then Ekind (Entity (Prefix (Exp))) = E_Constant + then + declare + Acc_Const : Entity_Id := Entity (Prefix (Exp)); + Acc_Const_Value : Node_Id := Empty; + begin + -- look through constants initialized to constants + loop + exit when Nkind (Parent (Acc_Const)) /= N_Object_Declaration; + + Acc_Const_Value := Expression (Parent (Acc_Const)); + + if Nkind (Acc_Const_Value) = N_Identifier + and then Ekind (Entity (Acc_Const_Value)) = E_Constant + then + Acc_Const := Entity (Acc_Const_Value); + else + exit; + end if; + end loop; + + if Nkind (Acc_Const_Value) = N_Allocator + and then Nkind (Expression (Acc_Const_Value)) + = N_Qualified_Expression + then + Result := + Etype (Expression (Acc_Const_Value)); + end if; + end; + end if; + + if Is_Constrained (Result) then + return Result; + end if; + + -- no constrained subtype found + return Etype (Exp); + end Constraint_Bearing_Subtype_If_Any; + + ---------------------- + -- Discr_Expression -- + ---------------------- + + function Discr_Expression + (Typ : Entity_Id; Discr_Index : Positive) return Node_Id + is + Constraint_Elmt : Elmt_Id := + First_Elmt (Discriminant_Constraint (Typ)); + begin + for Skip in 1 .. Discr_Index - 1 loop + Next_Elmt (Constraint_Elmt); + end loop; + return Node (Constraint_Elmt); + end Discr_Expression; + + ------------------------------------------------- + -- Has_Level_Tied_To_Explicitly_Aliased_Param -- + ------------------------------------------------- + + function Has_Level_Tied_To_Explicitly_Aliased_Param + (Constraint_Exp : Node_Id) return Boolean + is + Discr_Exp : Node_Id := Constraint_Exp; + Attr_Prefix : Node_Id; + begin + -- look through constants + while Nkind (Discr_Exp) = N_Identifier + and then Ekind (Entity (Discr_Exp)) = E_Constant + and then Nkind (Parent (Entity (Discr_Exp))) = N_Object_Declaration + loop + Discr_Exp := Expression (Parent (Entity (Discr_Exp))); + end loop; + + if Nkind (Discr_Exp) = N_Attribute_Reference + and then Get_Attribute_Id + (Attribute_Name (Discr_Exp)) = Attribute_Access + then + Attr_Prefix := Ultimate_Prefix (Prefix (Discr_Exp)); + if Is_Entity_Name (Attr_Prefix) + and then Is_Explicitly_Aliased (Entity (Attr_Prefix)) + and then Scope (Entity (Attr_Prefix)) = Func + then + return True; + end if; + end if; + + return False; + end Has_Level_Tied_To_Explicitly_Aliased_Param; + + Discr : Entity_Id := First_Discriminant (Etype (Exp)); + Discr_Index : Positive := 1; + Discr_Exp : Node_Id; + + Constrained_Subtype : constant Entity_Id := + Constraint_Bearing_Subtype_If_Any (Exp); + begin + -- ??? Do not generate a check if version is Ada 95 (or earlier). + -- It is unclear whether this is really correct, or is just a stopgap + -- measure. Investigation is needed to decide how post-Ada-95 binding + -- interpretation changes in RM 3.10.2 should interact with Ada 95's + -- return-by-reference model for functions with limited result types + -- (which was abandoned in Ada 2005). + + if Ada_Version <= Ada_95 then + return; + end if; + + -- If we are returning a function call then that function will + -- perform the needed check. + + if Nkind (Unqualify (Exp)) = N_Function_Call then + return; + end if; + + -- ??? Cope with the consequences of the Disable_Tagged_Cases flag + -- in accessibility.adb (which can cause the extra formal parameter + -- needed for the check(s) generated here to be missing in the case + -- of a tagged result type); this is a workaround and can + -- prevent generation of a required check. + + if No (Extra_Accessibility_Of_Result (Func)) then + return; + end if; + + Remove_Side_Effects (Exp); + + while Present (Discr) loop + if Is_Anonymous_Access_Type (Etype (Discr)) then + if Is_Constrained (Constrained_Subtype) then + Discr_Exp := + New_Copy_Tree + (Discr_Expression (Constrained_Subtype, Discr_Index)); + else + Discr_Exp := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Exp), + Selector_Name => New_Occurrence_Of (Discr, Loc)); + end if; + + if not Has_Level_Tied_To_Explicitly_Aliased_Param (Discr_Exp) then + declare + -- We could do this min operation earlier, as is done + -- for other implicit level parameters. Motivation for + -- doing this min operation (earlier or not) is as for + -- Generate_Minimum_Accessibility (see sem_ch6.adb): + -- if a level value is too big, then the caller and the + -- callee disagree about what it means. + + Level_Of_Master_Of_Call : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Natural, Loc), + Attribute_Name => Name_Min, + Expressions => New_List ( + Make_Integer_Literal (Loc, Scope_Depth (Func)), + New_Occurrence_Of + (Extra_Accessibility_Of_Result (Func), Loc))); + + Discrim_Level : Node_Id; + begin + Analyze (Level_Of_Master_Of_Call); + Analyze (Discr_Exp); + + Discrim_Level := + Accessibility_Level (Discr_Exp, Level => Dynamic_Level); + Analyze (Discrim_Level); + + Insert_Action (Exp, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Discrim_Level, + Right_Opnd => Level_Of_Master_Of_Call), + Reason => PE_Accessibility_Check_Failed), + Suppress => Access_Check); + end; + end if; + end if; + + Next_Discriminant (Discr); + Discr_Index := Discr_Index + 1; + end loop; + end Apply_Access_Discrims_Accessibility_Check; + ---------------------------------- -- Apply_CW_Accessibility_Check -- ---------------------------------- @@ -1155,13 +1407,18 @@ package body Exp_Ch6 is (Subp_Call : Node_Id; Subp_Id : Entity_Id) return Boolean is - Formal : Entity_Id; + use Deferred_Extra_Formals_Support; + Actual : Node_Id; + Formal : Entity_Id; begin pragma Assert (Nkind (Subp_Call) in N_Entry_Call_Statement | N_Function_Call | N_Procedure_Call_Statement); + pragma Assert (Extra_Formals_Known (Subp_Id) + or else not Expander_Active + or else Is_Unsupported_Extra_Actuals_Call (Subp_Call, Subp_Id)); -- In CodePeer_Mode, the tree for `'Elab_Spec` procedures will be -- malformed because GNAT does not perform the usual expansion that @@ -2866,15 +3123,17 @@ package body Exp_Ch6 is ----------------- procedure Expand_Call (N : Node_Id) is - function Is_Unchecked_Union_Equality (N : Node_Id) return Boolean; + function Is_Unchecked_Union_Predefined_Equality_Call + (N : Node_Id) return Boolean; -- Return True if N is a call to the predefined equality operator of an -- unchecked union type, or a renaming thereof. - --------------------------------- - -- Is_Unchecked_Union_Equality -- - --------------------------------- + ------------------------------------------------- + -- Is_Unchecked_Union_Predefined_Equality_Call -- + ------------------------------------------------- - function Is_Unchecked_Union_Equality (N : Node_Id) return Boolean is + function Is_Unchecked_Union_Predefined_Equality_Call + (N : Node_Id) return Boolean is begin if Is_Entity_Name (Name (N)) and then Ekind (Entity (Name (N))) = E_Function @@ -2899,7 +3158,7 @@ package body Exp_Ch6 is else return False; end if; - end Is_Unchecked_Union_Equality; + end Is_Unchecked_Union_Predefined_Equality_Call; -- If this is an indirect call through an Access_To_Subprogram -- with contract specifications, it is rewritten as a call to @@ -2996,7 +3255,7 @@ package body Exp_Ch6 is -- Case of a call to the predefined equality operator of an unchecked -- union type, which requires specific processing. - elsif Is_Unchecked_Union_Equality (N) then + elsif Is_Unchecked_Union_Predefined_Equality_Call (N) then declare Eq : constant Entity_Id := Entity (Name (N)); @@ -3020,29 +3279,12 @@ package body Exp_Ch6 is end if; end Expand_Call; - ------------------------ - -- Expand_Call_Helper -- - ------------------------ - - -- This procedure handles expansion of function calls and procedure call - -- statements (i.e. it serves as the body for Expand_N_Function_Call and - -- Expand_N_Procedure_Call_Statement). Processing for calls includes: - - -- Replace call to Raise_Exception by Raise_Exception_Always if possible - -- Provide values of actuals for all formals in Extra_Formals list - -- Replace "call" to enumeration literal function by literal itself - -- Rewrite call to predefined operator as operator - -- Replace actuals to in-out parameters that are numeric conversions, - -- with explicit assignment to temporaries before and after the call. - - -- Note that the list of actuals has been filled with default expressions - -- during semantic analysis of the call. Only the extra actuals required - -- for the 'Constrained attribute and for accessibility checks are added - -- at this point. + -------------------------- + -- Create_Extra_Actuals -- + -------------------------- - procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is - Loc : constant Source_Ptr := Sloc (N); - Call_Node : Node_Id := N; + procedure Create_Extra_Actuals (Call_Node : Node_Id) is + Loc : constant Source_Ptr := Sloc (Call_Node); Extra_Actuals : List_Id := No_List; Prev : Node_Id := Empty; @@ -3072,88 +3314,6 @@ package body Exp_Ch6 is -- expression for the value of the actual, EF is the entity for the -- extra formal. - procedure Add_View_Conversion_Invariants - (Formal : Entity_Id; - Actual : Node_Id); - -- Adds invariant checks for every intermediate type between the range - -- of a view converted argument to its ancestor (from parent to child). - - function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean; - -- Try to constant-fold a predicate check, which often enough is a - -- simple arithmetic expression that can be computed statically if - -- its argument is static. This cleans up the output of CCG, even - -- though useless predicate checks will be generally removed by - -- back-end optimizations. - - procedure Check_Subprogram_Variant; - -- Emit a call to the internally generated procedure with checks for - -- aspect Subprogram_Variant, if present and enabled. - - function Inherited_From_Formal (S : Entity_Id) return Entity_Id; - -- Within an instance, a type derived from an untagged formal derived - -- type inherits from the original parent, not from the actual. The - -- current derivation mechanism has the derived type inherit from the - -- actual, which is only correct outside of the instance. If the - -- subprogram is inherited, we test for this particular case through a - -- convoluted tree traversal before setting the proper subprogram to be - -- called. - - function In_Unfrozen_Instance (E : Entity_Id) return Boolean; - -- Return true if E comes from an instance that is not yet frozen - - function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean; - -- Return True when E is a class-wide interface type or an access to - -- a class-wide interface type. - - function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; - -- Determine if Subp denotes a non-dispatching call to a Deep routine - - function New_Value (From : Node_Id) return Node_Id; - -- From is the original Expression. New_Value is equivalent to a call - -- to Duplicate_Subexpr with an explicit dereference when From is an - -- access parameter. - - -------------------------- - -- Add_Actual_Parameter -- - -------------------------- - - procedure Add_Actual_Parameter (Insert_Param : Node_Id) is - Actual_Expr : constant Node_Id := - Explicit_Actual_Parameter (Insert_Param); - - begin - -- Case of insertion is first named actual - - if No (Prev) or else - Nkind (Parent (Prev)) /= N_Parameter_Association - then - Set_Next_Named_Actual - (Insert_Param, First_Named_Actual (Call_Node)); - Set_First_Named_Actual (Call_Node, Actual_Expr); - - if No (Prev) then - if No (Parameter_Associations (Call_Node)) then - Set_Parameter_Associations (Call_Node, New_List); - end if; - - Append (Insert_Param, Parameter_Associations (Call_Node)); - - else - Insert_After (Prev, Insert_Param); - end if; - - -- Case of insertion is not first named actual - - else - Set_Next_Named_Actual - (Insert_Param, Next_Named_Actual (Parent (Prev))); - Set_Next_Named_Actual (Parent (Prev), Actual_Expr); - Append (Insert_Param, Parameter_Associations (Call_Node)); - end if; - - Prev := Actual_Expr; - end Add_Actual_Parameter; - -------------------------------------- -- Add_Cond_Expression_Extra_Actual -- -------------------------------------- @@ -3368,14 +3528,14 @@ package body Exp_Ch6 is if Etype (Formal) = Standard_Natural then Actual := Make_Integer_Literal (Loc, Uint_0); Analyze_And_Resolve (Actual, Standard_Natural); - Add_Extra_Actual_To_Call (N, Formal, Actual); + Add_Extra_Actual_To_Call (Call_Node, Formal, Actual); -- BIPtaskmaster elsif Etype (Formal) = Standard_Integer then Actual := Make_Integer_Literal (Loc, Uint_0); Analyze_And_Resolve (Actual, Standard_Integer); - Add_Extra_Actual_To_Call (N, Formal, Actual); + Add_Extra_Actual_To_Call (Call_Node, Formal, Actual); -- BIPstoragepool, BIPcollection, BIPactivationchain, -- and BIPaccess. @@ -3383,7 +3543,7 @@ package body Exp_Ch6 is elsif Is_Access_Type (Etype (Formal)) then Actual := Make_Null (Loc); Analyze_And_Resolve (Actual, Etype (Formal)); - Add_Extra_Actual_To_Call (N, Formal, Actual); + Add_Extra_Actual_To_Call (Call_Node, Formal, Actual); else pragma Assert (False); @@ -3402,6 +3562,47 @@ package body Exp_Ch6 is pragma Assert (Check_BIP_Actuals (Call_Node, Function_Id)); end Add_Dummy_Build_In_Place_Actuals; + -------------------------- + -- Add_Actual_Parameter -- + -------------------------- + + procedure Add_Actual_Parameter (Insert_Param : Node_Id) is + Actual_Expr : constant Node_Id := + Explicit_Actual_Parameter (Insert_Param); + + begin + -- Case of insertion is first named actual + + if No (Prev) + or else Nkind (Parent (Prev)) /= N_Parameter_Association + then + Set_Next_Named_Actual + (Insert_Param, First_Named_Actual (Call_Node)); + Set_First_Named_Actual (Call_Node, Actual_Expr); + + if No (Prev) then + if No (Parameter_Associations (Call_Node)) then + Set_Parameter_Associations (Call_Node, New_List); + end if; + + Append (Insert_Param, Parameter_Associations (Call_Node)); + + else + Insert_After (Prev, Insert_Param); + end if; + + -- Case of insertion is not first named actual + + else + Set_Next_Named_Actual + (Insert_Param, Next_Named_Actual (Parent (Prev))); + Set_Next_Named_Actual (Parent (Prev), Actual_Expr); + Append (Insert_Param, Parameter_Associations (Call_Node)); + end if; + + Prev := Actual_Expr; + end Add_Actual_Parameter; + ---------------------- -- Add_Extra_Actual -- ---------------------- @@ -3427,6 +3628,421 @@ package body Exp_Ch6 is end if; end Add_Extra_Actual; + -- Local variables + + use Deferred_Extra_Formals_Support; + + Actual : Node_Id; + Formal : Entity_Id; + Param_Count : Positive; + Subp : constant Entity_Id := Get_Called_Entity (Call_Node); + + -- Start of processing for Create_Extra_Actuals + + begin + -- Special case: Thunks must not compute the extra actuals; they must + -- just propagate their extra actuals to the target primitive. + + if Is_Thunk (Current_Scope) + and then Thunk_Entity (Current_Scope) = Subp + then + declare + Target_Formal : Entity_Id; + Thunk_Formal : Entity_Id; + + begin + pragma Assert (Extra_Formals_Known (Subp) + and then Extra_Formals_Match_OK (Current_Scope, Subp)); + + Target_Formal := Extra_Formals (Subp); + Thunk_Formal := Extra_Formals (Current_Scope); + while Present (Target_Formal) loop + Add_Extra_Actual + (Expr => New_Occurrence_Of (Thunk_Formal, Loc), + EF => Thunk_Formal); + + Target_Formal := Extra_Formal (Target_Formal); + Thunk_Formal := Extra_Formal (Thunk_Formal); + end loop; + + while Is_Non_Empty_List (Extra_Actuals) loop + Add_Actual_Parameter (Remove_Head (Extra_Actuals)); + end loop; + + return; + end; + end if; + + pragma Assert (Extra_Formals_Known (Subp) + or else Is_Unsupported_Extra_Formals_Entity (Subp)); + + -- First step, compute extra actuals, corresponding to any Extra_Formals + -- present. Note that we do not access Extra_Formals directly; instead + -- we generate and collect the corresponding actuals in Extra_Actuals. + + Formal := First_Formal (Subp); + Actual := First_Actual (Call_Node); + Param_Count := 1; + while Present (Formal) loop + -- Prepare to examine current entry + + Prev := Actual; + + -- Create possible extra actual for constrained case. Usually, the + -- extra actual is of the form actual'constrained, but since this + -- attribute is only available for unconstrained records, TRUE is + -- expanded if the type of the formal happens to be constrained (for + -- instance when this procedure is inherited from an unconstrained + -- record to a constrained one) or if the actual has no discriminant + -- (its type is constrained). An exception to this is the case of a + -- private type without discriminants. In this case we pass FALSE + -- because the object has underlying discriminants with defaults. + + if Present (Extra_Constrained (Formal)) then + if Is_Mutably_Tagged_Type (Etype (Actual)) + or else (Is_Private_Type (Etype (Prev)) + and then not Has_Discriminants + (Base_Type (Etype (Prev)))) + then + Add_Extra_Actual + (Expr => New_Occurrence_Of (Standard_False, Loc), + EF => Extra_Constrained (Formal)); + + elsif Is_Constrained (Etype (Formal)) + or else not Has_Discriminants (Etype (Prev)) + then + Add_Extra_Actual + (Expr => New_Occurrence_Of (Standard_True, Loc), + EF => Extra_Constrained (Formal)); + + -- Do not produce extra actuals for Unchecked_Union parameters. + -- Jump directly to the end of the loop. + + elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then + goto Skip_Extra_Actual_Generation; + + else + -- If the actual is a type conversion, then the constrained + -- test applies to the actual, not the target type. + + declare + Act_Prev : Node_Id; + + begin + -- Test for unchecked conversions as well, which can occur + -- as out parameter actuals on calls to stream procedures. + + Act_Prev := Prev; + while Nkind (Act_Prev) in N_Type_Conversion + | N_Unchecked_Type_Conversion + loop + Act_Prev := Expression (Act_Prev); + end loop; + + -- If the expression is a conversion of a dereference, this + -- is internally generated code that manipulates addresses, + -- e.g. when building interface tables. No check should + -- occur in this case, and the discriminated object is not + -- directly at hand. + + if not Comes_From_Source (Actual) + and then Nkind (Actual) = N_Unchecked_Type_Conversion + and then Nkind (Act_Prev) = N_Explicit_Dereference + then + Add_Extra_Actual + (Expr => New_Occurrence_Of (Standard_False, Loc), + EF => Extra_Constrained (Formal)); + + else + Add_Extra_Actual + (Expr => + Make_Attribute_Reference (Sloc (Prev), + Prefix => + Duplicate_Subexpr_No_Checks + (Act_Prev, Name_Req => True), + Attribute_Name => Name_Constrained), + EF => Extra_Constrained (Formal)); + end if; + end; + end if; + end if; + + -- Create possible extra actual for accessibility level + + if Present (Extra_Accessibility (Formal)) then + + -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of + -- accessibility levels. + + if Is_Thunk (Current_Scope) then + declare + Parm_Ent : Entity_Id; + + begin + if Is_Controlling_Actual (Actual) then + + -- Find the corresponding actual of the thunk + + Parm_Ent := First_Entity (Current_Scope); + for J in 2 .. Param_Count loop + Next_Entity (Parm_Ent); + end loop; + + -- Handle unchecked conversion of access types generated + -- in thunks (cf. Expand_Interface_Thunk). + + elsif Is_Access_Type (Etype (Actual)) + and then Nkind (Actual) = N_Unchecked_Type_Conversion + then + Parm_Ent := Entity (Expression (Actual)); + + else pragma Assert (Is_Entity_Name (Actual)); + Parm_Ent := Entity (Actual); + end if; + + Add_Extra_Actual + (Expr => Accessibility_Level + (Expr => Parm_Ent, + Level => Dynamic_Level, + Allow_Alt_Model => False), + EF => Extra_Accessibility (Formal)); + end; + + -- Conditional expressions + + elsif Nkind (Prev) = N_Expression_With_Actions + and then Nkind (Original_Node (Prev)) in + N_If_Expression | N_Case_Expression + then + Add_Cond_Expression_Extra_Actual (Formal); + + -- Internal constant generated to remove side effects (normally + -- from the expansion of dispatching calls). + + -- First verify the actual is internal + + elsif not Comes_From_Source (Prev) + and then not Is_Rewrite_Substitution (Prev) + + -- Next check that the actual is a constant + + and then Nkind (Prev) = N_Identifier + and then Ekind (Entity (Prev)) = E_Constant + and then Nkind (Parent (Entity (Prev))) = N_Object_Declaration + then + -- Generate the accessibility level based on the expression in + -- the constant's declaration. + + declare + Ent : Entity_Id := Entity (Prev); + + begin + -- Handle deferred constants + + if Present (Full_View (Ent)) then + Ent := Full_View (Ent); + end if; + + Add_Extra_Actual + (Expr => Accessibility_Level + (Expr => Expression (Parent (Ent)), + Level => Dynamic_Level, + Allow_Alt_Model => False), + EF => Extra_Accessibility (Formal)); + end; + + -- Normal case + + else + Add_Extra_Actual + (Expr => Accessibility_Level + (Expr => Prev, + Level => Dynamic_Level, + Allow_Alt_Model => False), + EF => Extra_Accessibility (Formal)); + end if; + end if; + + -- This label is required when skipping extra actual generation for + -- Unchecked_Union parameters. + + <<Skip_Extra_Actual_Generation>> + + Param_Count := Param_Count + 1; + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + + -- If we are calling an Ada 2012 function which needs to have the + -- "accessibility level determined by the point of call" (AI05-0234) + -- passed in to it, then pass it in. + + if Ekind (Subp) in E_Function | E_Operator | E_Subprogram_Type + and then + Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))) + then + declare + Extra_Form : Node_Id := Empty; + Level : Node_Id := Empty; + + begin + -- Detect cases where the function call has been internally + -- generated by examining the original node and return library + -- level - taking care to avoid ignoring function calls expanded + -- in prefix notation. + + if Nkind (Original_Node (Call_Node)) not in N_Function_Call + | N_Selected_Component + | N_Indexed_Component + then + Level := Make_Integer_Literal + (Loc, Scope_Depth (Standard_Standard)); + + -- Otherwise get the level normally based on the call node + + else + Level := Accessibility_Level + (Expr => Call_Node, + Level => Dynamic_Level, + Allow_Alt_Model => False); + end if; + + -- It may be possible that we are re-expanding an already + -- expanded call when are are dealing with dispatching ??? + + if No (Parameter_Associations (Call_Node)) + or else Nkind (Last (Parameter_Associations (Call_Node))) + /= N_Parameter_Association + or else not Is_Accessibility_Actual + (Last (Parameter_Associations (Call_Node))) + then + Extra_Form := Extra_Accessibility_Of_Result + (Ultimate_Alias (Subp)); + + Add_Extra_Actual + (Expr => Level, + EF => Extra_Form); + end if; + end; + end if; + + -- Second step: In the previous loop we gathered the extra actuals (the + -- ones that correspond to Extra_Formals), so now they can be appended. + + if Is_Non_Empty_List (Extra_Actuals) then + declare + Num_Extra_Actuals : constant Nat := List_Length (Extra_Actuals); + + begin + while Is_Non_Empty_List (Extra_Actuals) loop + Add_Actual_Parameter (Remove_Head (Extra_Actuals)); + end loop; + + -- Add dummy extra BIP actuals if we are calling a function that + -- inherited the BIP extra actuals but does not require them. + + if Nkind (Call_Node) = N_Function_Call + and then Is_Function_Call_With_BIP_Formals (Call_Node) + and then not Is_Build_In_Place_Function_Call (Call_Node) + then + Add_Dummy_Build_In_Place_Actuals (Subp, + Num_Added_Extra_Actuals => Num_Extra_Actuals); + end if; + end; + + -- Add dummy extra BIP actuals if we are calling a function that + -- inherited the BIP extra actuals but does not require them. + + elsif Nkind (Call_Node) = N_Function_Call + and then Is_Function_Call_With_BIP_Formals (Call_Node) + and then not Is_Build_In_Place_Function_Call (Call_Node) + then + Add_Dummy_Build_In_Place_Actuals (Subp); + end if; + + -- For non build-in-place calls formals and actuals must match; + -- for build-in-place function calls, the pending bip actuals are + -- added by the following subprograms as part of the bottom-up + -- expansion of the call (and this check will be performed there): + -- Make_Build_In_Place_Call_In_Allocator + -- Make_Build_In_Place_Call_In_Anonymous_Context + -- Make_Build_In_Place_Call_In_Assignment + -- Make_Build_In_Place_Call_In_Object_Declaration + -- Make_Build_In_Place_Iface_Call_In_Allocator + -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context + -- Make_Build_In_Place_Iface_Call_In_Object_Declaration + + pragma Assert (Is_Build_In_Place_Function_Call (Call_Node) + or else (Check_Number_Of_Actuals (Call_Node, Subp) + and then Check_BIP_Actuals (Call_Node, Subp))); + end Create_Extra_Actuals; + + ------------------------ + -- Expand_Call_Helper -- + ------------------------ + + -- This procedure handles expansion of function calls and procedure call + -- statements (i.e. it serves as the body for Expand_N_Function_Call and + -- Expand_N_Procedure_Call_Statement). Processing for calls includes: + + -- Replace call to Raise_Exception by Raise_Exception_Always if possible + -- Provide values of actuals for all formals in Extra_Formals list + -- Replace "call" to enumeration literal function by literal itself + -- Rewrite call to predefined operator as operator + -- Replace actuals to in-out parameters that are numeric conversions, + -- with explicit assignment to temporaries before and after the call. + + -- Note that the list of actuals has been filled with default expressions + -- during semantic analysis of the call. Only the extra actuals required + -- for the 'Constrained attribute and for accessibility checks are added + -- at this point. + + procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is + Loc : constant Source_Ptr := Sloc (N); + Call_Node : Node_Id := N; + Prev : Node_Id := Empty; + + procedure Add_View_Conversion_Invariants + (Formal : Entity_Id; + Actual : Node_Id); + -- Adds invariant checks for every intermediate type between the range + -- of a view converted argument to its ancestor (from parent to child). + + function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean; + -- Try to constant-fold a predicate check, which often enough is a + -- simple arithmetic expression that can be computed statically if + -- its argument is static. This cleans up the output of CCG, even + -- though useless predicate checks will be generally removed by + -- back-end optimizations. + + procedure Check_Subprogram_Variant; + -- Emit a call to the internally generated procedure with checks for + -- aspect Subprogram_Variant, if present and enabled. + + function Inherited_From_Formal (S : Entity_Id) return Entity_Id; + -- Within an instance, a type derived from an untagged formal derived + -- type inherits from the original parent, not from the actual. The + -- current derivation mechanism has the derived type inherit from the + -- actual, which is only correct outside of the instance. If the + -- subprogram is inherited, we test for this particular case through a + -- convoluted tree traversal before setting the proper subprogram to be + -- called. + + function In_Unfrozen_Instance (E : Entity_Id) return Boolean; + -- Return true if E comes from an instance that is not yet frozen + + function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean; + -- Return True when E is a class-wide interface type or an access to + -- a class-wide interface type. + + function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; + -- Determine if Subp denotes a non-dispatching call to a Deep routine + + function New_Value (From : Node_Id) return Node_Id; + -- From is the original Expression. New_Value is equivalent to a call + -- to Duplicate_Subexpr with an explicit dereference when From is an + -- access parameter. + ------------------------------------ -- Add_View_Conversion_Invariants -- ------------------------------------ @@ -3943,6 +4559,9 @@ package body Exp_Ch6 is Subp : Entity_Id; CW_Interface_Formals_Present : Boolean := False; + Defer_Extra_Actuals : Boolean := False; + + use Deferred_Extra_Formals_Support; -- Start of processing for Expand_Call_Helper @@ -4029,12 +4648,6 @@ package body Exp_Ch6 is end if; end if; - -- Ensure that the called subprogram has all its formals - - if not Is_Frozen (Subp) then - Create_Extra_Formals (Subp); - end if; - -- Ada 2005 (AI-345): We have a procedure call as a triggering -- alternative in an asynchronous select or as an entry call in -- a conditional or timed select. Check whether the procedure call @@ -4080,6 +4693,50 @@ package body Exp_Ch6 is end; end if; + -- Ensure that the called subprogram has all its formals; extra formals + -- of init procs were added when they were built. + + if not Extra_Formals_Known (Subp) then + Create_Extra_Formals (Subp); + + -- If the previous call to Create_Extra_Formals could not add the + -- extra formals, then we must defer adding the extra actuals of + -- this call until we know the underlying type of all the formals + -- and return type of the called subprogram or entry. Deferral of + -- extra actuals occurs in two cases: + -- 1) In the body of internally built dynamic call helpers of + -- class-wide preconditions. + -- 2) In the body of expanded expression functions. + + if not Extra_Formals_Known (Subp) then + declare + Scop_Id : Entity_Id := Current_Scope; + + begin + -- Locate the enclosing subprogram or entry since it is + -- required to register this deferred call. + + Scop_Id := Current_Scope; + while Present (Scop_Id) + and then Scop_Id /= Standard_Standard + and then not Is_Subprogram_Or_Entry (Scop_Id) + loop + Scop_Id := Scope (Scop_Id); + end loop; + + pragma Assert (Is_Subprogram_Or_Entry (Scop_Id)); + pragma Assert (Is_Deferred_Extra_Formals_Entity (Subp)); + Register_Deferred_Extra_Formals_Call (Call_Node, Scop_Id); + + Defer_Extra_Actuals := True; + end; + end if; + end if; + + pragma Assert (Extra_Formals_Known (Subp) + or else Is_Deferred_Extra_Formals_Entity (Subp) + or else Is_Unsupported_Extra_Formals_Entity (Subp)); + -- If this is a call to a predicate function, try to constant fold it if Nkind (Call_Node) = N_Function_Call @@ -4091,56 +4748,39 @@ package body Exp_Ch6 is end if; -- First step, compute extra actuals, corresponding to any Extra_Formals - -- present. Note that we do not access Extra_Formals directly, instead + -- present. Note that we do not access Extra_Formals directly; instead -- we simply note the presence of the extra formals as we process the -- regular formals collecting corresponding actuals in Extra_Actuals. - -- We also generate any required range checks for actuals for in formals - -- as we go through the loop, since this is a convenient place to do it. - -- (Though it seems that this would be better done in Expand_Actuals???) + -- We also generate any required range checks for actuals for in-mode + -- formals as we go through the loop, since this is a convenient place + -- to do it. (Though it seems that this would be better done in + -- Expand_Actuals???) -- Special case: Thunks must not compute the extra actuals; they must - -- just propagate to the target primitive their extra actuals. + -- just propagate their extra actuals to the target primitive (this + -- propagation is performed by Create_Extra_Actuals). if Is_Thunk (Current_Scope) and then Thunk_Entity (Current_Scope) = Subp + and then Extra_Formals_Known (Subp) and then Present (Extra_Formals (Subp)) then - pragma Assert (Extra_Formals_Match_OK (Current_Scope, Subp)); + Create_Extra_Actuals (N); - declare - Target_Formal : Entity_Id; - Thunk_Formal : Entity_Id; - - begin - Target_Formal := Extra_Formals (Subp); - Thunk_Formal := Extra_Formals (Current_Scope); - while Present (Target_Formal) loop - Add_Extra_Actual - (Expr => New_Occurrence_Of (Thunk_Formal, Loc), - EF => Thunk_Formal); - - Target_Formal := Extra_Formal (Target_Formal); - Thunk_Formal := Extra_Formal (Thunk_Formal); - end loop; - - while Is_Non_Empty_List (Extra_Actuals) loop - Add_Actual_Parameter (Remove_Head (Extra_Actuals)); - end loop; + -- Mark the call as an expanded build-in-place call; required + -- to avoid adding the extra formals twice. - -- Mark the call as processed build-in-place call; required - -- to avoid adding the extra formals twice. + if Nkind (Call_Node) = N_Function_Call then + Set_Is_Expanded_Build_In_Place_Call (Call_Node); + end if; - if Nkind (Call_Node) = N_Function_Call then - Set_Is_Expanded_Build_In_Place_Call (Call_Node); - end if; + Expand_Actuals (Call_Node, Subp, Post_Call); - Expand_Actuals (Call_Node, Subp, Post_Call); - pragma Assert (Is_Empty_List (Post_Call)); - pragma Assert (Check_Number_Of_Actuals (Call_Node, Subp)); - pragma Assert (Check_BIP_Actuals (Call_Node, Subp)); - return; - end; + pragma Assert (Is_Empty_List (Post_Call)); + pragma Assert (Check_Number_Of_Actuals (Call_Node, Subp)); + pragma Assert (Check_BIP_Actuals (Call_Node, Subp)); + return; end if; Formal := First_Formal (Subp); @@ -4158,180 +4798,6 @@ package body Exp_Ch6 is CW_Interface_Formals_Present or else Is_Class_Wide_Interface_Type (Etype (Formal)); - -- Create possible extra actual for constrained case. Usually, the - -- extra actual is of the form actual'constrained, but since this - -- attribute is only available for unconstrained records, TRUE is - -- expanded if the type of the formal happens to be constrained (for - -- instance when this procedure is inherited from an unconstrained - -- record to a constrained one) or if the actual has no discriminant - -- (its type is constrained). An exception to this is the case of a - -- private type without discriminants. In this case we pass FALSE - -- because the object has underlying discriminants with defaults. - - if Present (Extra_Constrained (Formal)) then - if Is_Mutably_Tagged_Type (Etype (Actual)) - or else (Is_Private_Type (Etype (Prev)) - and then not Has_Discriminants - (Base_Type (Etype (Prev)))) - then - Add_Extra_Actual - (Expr => New_Occurrence_Of (Standard_False, Loc), - EF => Extra_Constrained (Formal)); - - elsif Is_Constrained (Etype (Formal)) - or else not Has_Discriminants (Etype (Prev)) - then - Add_Extra_Actual - (Expr => New_Occurrence_Of (Standard_True, Loc), - EF => Extra_Constrained (Formal)); - - -- Do not produce extra actuals for Unchecked_Union parameters. - -- Jump directly to the end of the loop. - - elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then - goto Skip_Extra_Actual_Generation; - - else - -- If the actual is a type conversion, then the constrained - -- test applies to the actual, not the target type. - - declare - Act_Prev : Node_Id; - - begin - -- Test for unchecked conversions as well, which can occur - -- as out parameter actuals on calls to stream procedures. - - Act_Prev := Prev; - while Nkind (Act_Prev) in N_Type_Conversion - | N_Unchecked_Type_Conversion - loop - Act_Prev := Expression (Act_Prev); - end loop; - - -- If the expression is a conversion of a dereference, this - -- is internally generated code that manipulates addresses, - -- e.g. when building interface tables. No check should - -- occur in this case, and the discriminated object is not - -- directly at hand. - - if not Comes_From_Source (Actual) - and then Nkind (Actual) = N_Unchecked_Type_Conversion - and then Nkind (Act_Prev) = N_Explicit_Dereference - then - Add_Extra_Actual - (Expr => New_Occurrence_Of (Standard_False, Loc), - EF => Extra_Constrained (Formal)); - - else - Add_Extra_Actual - (Expr => - Make_Attribute_Reference (Sloc (Prev), - Prefix => - Duplicate_Subexpr_No_Checks - (Act_Prev, Name_Req => True), - Attribute_Name => Name_Constrained), - EF => Extra_Constrained (Formal)); - end if; - end; - end if; - end if; - - -- Create possible extra actual for accessibility level - - if Present (Extra_Accessibility (Formal)) then - -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of - -- accessibility levels. - - if Is_Thunk (Current_Scope) then - declare - Parm_Ent : Entity_Id; - - begin - if Is_Controlling_Actual (Actual) then - - -- Find the corresponding actual of the thunk - - Parm_Ent := First_Entity (Current_Scope); - for J in 2 .. Param_Count loop - Next_Entity (Parm_Ent); - end loop; - - -- Handle unchecked conversion of access types generated - -- in thunks (cf. Expand_Interface_Thunk). - - elsif Is_Access_Type (Etype (Actual)) - and then Nkind (Actual) = N_Unchecked_Type_Conversion - then - Parm_Ent := Entity (Expression (Actual)); - - else pragma Assert (Is_Entity_Name (Actual)); - Parm_Ent := Entity (Actual); - end if; - - Add_Extra_Actual - (Expr => Accessibility_Level - (Expr => Parm_Ent, - Level => Dynamic_Level, - Allow_Alt_Model => False), - EF => Extra_Accessibility (Formal)); - end; - - -- Conditional expressions - - elsif Nkind (Prev) = N_Expression_With_Actions - and then Nkind (Original_Node (Prev)) in - N_If_Expression | N_Case_Expression - then - Add_Cond_Expression_Extra_Actual (Formal); - - -- Internal constant generated to remove side effects (normally - -- from the expansion of dispatching calls). - - -- First verify the actual is internal - - elsif not Comes_From_Source (Prev) - and then not Is_Rewrite_Substitution (Prev) - - -- Next check that the actual is a constant - - and then Nkind (Prev) = N_Identifier - and then Ekind (Entity (Prev)) = E_Constant - and then Nkind (Parent (Entity (Prev))) = N_Object_Declaration - then - -- Generate the accessibility level based on the expression in - -- the constant's declaration. - - declare - Ent : Entity_Id := Entity (Prev); - - begin - -- Handle deferred constants - - if Present (Full_View (Ent)) then - Ent := Full_View (Ent); - end if; - - Add_Extra_Actual - (Expr => Accessibility_Level - (Expr => Expression (Parent (Ent)), - Level => Dynamic_Level, - Allow_Alt_Model => False), - EF => Extra_Accessibility (Formal)); - end; - - -- Normal case - - else - Add_Extra_Actual - (Expr => Accessibility_Level - (Expr => Prev, - Level => Dynamic_Level, - Allow_Alt_Model => False), - EF => Extra_Accessibility (Formal)); - end if; - end if; - -- Perform the check of 4.6(49) that prevents a null value from being -- passed as an actual to an access parameter. Note that the check -- is elided in the common cases of passing an access attribute or @@ -4525,66 +4991,11 @@ package body Exp_Ch6 is -- This label is required when skipping extra actual generation for -- Unchecked_Union parameters. - <<Skip_Extra_Actual_Generation>> - Param_Count := Param_Count + 1; Next_Actual (Actual); Next_Formal (Formal); end loop; - -- If we are calling an Ada 2012 function which needs to have the - -- "accessibility level determined by the point of call" (AI05-0234) - -- passed in to it, then pass it in. - - if Ekind (Subp) in E_Function | E_Operator | E_Subprogram_Type - and then - Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))) - then - declare - Extra_Form : Node_Id := Empty; - Level : Node_Id := Empty; - - begin - -- Detect cases where the function call has been internally - -- generated by examining the original node and return library - -- level - taking care to avoid ignoring function calls expanded - -- in prefix notation. - - if Nkind (Original_Node (Call_Node)) not in N_Function_Call - | N_Selected_Component - | N_Indexed_Component - then - Level := Make_Integer_Literal - (Loc, Scope_Depth (Standard_Standard)); - - -- Otherwise get the level normally based on the call node - - else - Level := Accessibility_Level - (Expr => Call_Node, - Level => Dynamic_Level, - Allow_Alt_Model => False); - end if; - - -- It may be possible that we are re-expanding an already - -- expanded call when are are dealing with dispatching ??? - - if No (Parameter_Associations (Call_Node)) - or else Nkind (Last (Parameter_Associations (Call_Node))) - /= N_Parameter_Association - or else not Is_Accessibility_Actual - (Last (Parameter_Associations (Call_Node))) - then - Extra_Form := Extra_Accessibility_Of_Result - (Ultimate_Alias (Subp)); - - Add_Extra_Actual - (Expr => Level, - EF => Extra_Form); - end if; - end; - end if; - -- If we are expanding the RHS of an assignment we need to check if tag -- propagation is needed. You might expect this processing to be in -- Analyze_Assignment but has to be done earlier (bottom-up) because the @@ -4597,27 +5008,34 @@ package body Exp_Ch6 is then declare Ass : Node_Id := Empty; + Par : Node_Id := Parent (Call_Node); begin - if Nkind (Parent (Call_Node)) = N_Assignment_Statement then - Ass := Parent (Call_Node); + -- Search for the LHS of an enclosing assignment statement to a + -- classwide type object (if present) and propagate the tag to + -- this function call. + + while Nkind (Par) in N_Case_Expression + | N_Case_Expression_Alternative + | N_Explicit_Dereference + | N_If_Expression + | N_Qualified_Expression + | N_Unchecked_Type_Conversion + loop + if Nkind (Par) = N_Case_Expression_Alternative then + Par := Parent (Par); + end if; - elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression - and then Nkind (Parent (Parent (Call_Node))) = - N_Assignment_Statement - then - Ass := Parent (Parent (Call_Node)); + exit when not Is_Tag_Indeterminate (Par); - elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference - and then Nkind (Parent (Parent (Call_Node))) = - N_Assignment_Statement - then - Ass := Parent (Parent (Call_Node)); - end if; + Par := Parent (Par); + end loop; - if Present (Ass) - and then Is_Class_Wide_Type (Etype (Name (Ass))) + if Nkind (Par) = N_Assignment_Statement + and then Is_Class_Wide_Type (Etype (Name (Par))) then + Ass := Par; + -- Move the error messages below to sem??? if Is_Access_Type (Etype (Call_Node)) then @@ -4630,6 +5048,12 @@ package body Exp_Ch6 is Call_Node, Root_Type (Etype (Name (Ass)))); else Propagate_Tag (Name (Ass), Call_Node); + + -- Remember that the tag has been propagated to avoid + -- propagating it again, as part of the (bottom-up) + -- analysis of the enclosing assignment. + + Set_Tag_Propagated (Name (Ass)); end if; elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then @@ -4640,6 +5064,12 @@ package body Exp_Ch6 is else Propagate_Tag (Name (Ass), Call_Node); + + -- Remember that the tag has been propagated to avoid + -- propagating it again, as part of the (bottom-up) + -- analysis of the enclosing assignment. + + Set_Tag_Propagated (Name (Ass)); end if; -- The call will be rewritten as a dispatching call, and @@ -4778,38 +5208,12 @@ package body Exp_Ch6 is then null; - -- During that loop we gathered the extra actuals (the ones that - -- correspond to Extra_Formals), so now they can be appended. - - elsif Is_Non_Empty_List (Extra_Actuals) then - declare - Num_Extra_Actuals : constant Nat := List_Length (Extra_Actuals); - - begin - while Is_Non_Empty_List (Extra_Actuals) loop - Add_Actual_Parameter (Remove_Head (Extra_Actuals)); - end loop; - - -- Add dummy extra BIP actuals if we are calling a function that - -- inherited the BIP extra actuals but does not require them. - - if Nkind (Call_Node) = N_Function_Call - and then Is_Function_Call_With_BIP_Formals (Call_Node) - and then not Is_Build_In_Place_Function_Call (Call_Node) - then - Add_Dummy_Build_In_Place_Actuals (Subp, - Num_Added_Extra_Actuals => Num_Extra_Actuals); - end if; - end; - - -- Add dummy extra BIP actuals if we are calling a function that - -- inherited the BIP extra actuals but does not require them. + elsif not Defer_Extra_Actuals then + Create_Extra_Formals (Subp); - elsif Nkind (Call_Node) = N_Function_Call - and then Is_Function_Call_With_BIP_Formals (Call_Node) - and then not Is_Build_In_Place_Function_Call (Call_Node) - then - Add_Dummy_Build_In_Place_Actuals (Subp); + if Extra_Formals_Known (Subp) then + Create_Extra_Actuals (N); + end if; end if; -- At this point we have all the actuals, so this is the point at which @@ -5227,6 +5631,10 @@ package body Exp_Ch6 is -- also Build_Renamed_Body) cannot be expanded here because this may -- give rise to order-of-elaboration issues for the types of the -- parameters of the subprogram, if any. + -- + -- Expand_Inlined_Call procedure does not support the frontend + -- inlining of calls that return unconstrained types used as actuals + -- or in return statements. elsif Present (Unit_Declaration_Node (Subp)) and then Nkind (Unit_Declaration_Node (Subp)) = @@ -5235,6 +5643,8 @@ package body Exp_Ch6 is and then Nkind (Body_To_Inline (Unit_Declaration_Node (Subp))) not in N_Entity + and then Nkind (Parent (N)) /= N_Function_Call + and then Nkind (Parent (N)) /= N_Simple_Return_Statement then Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); @@ -7159,6 +7569,16 @@ package body Exp_Ch6 is then Apply_CW_Accessibility_Check (Exp, Scope_Id); + -- Check that result's access discrims (if any) do not designate + -- entities that the function result could outlive. See preceding + -- comment about extended return statements and thunks. + + elsif Has_Anonymous_Access_Discriminant (Exp_Typ) + and then not Comes_From_Extended_Return_Statement (N) + and then not Is_Thunk (Scope_Id) + then + Apply_Access_Discrims_Accessibility_Check (Exp, Scope_Id); + -- Ada 2012 (AI05-0073): If the result subtype of the function is -- defined by an access_definition designating a specific tagged -- type T, a check is made that the result value is null or the tag @@ -8557,6 +8977,8 @@ package body Exp_Ch6 is Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); Analyze_And_Resolve (Allocator, Acc_Type); + + pragma Assert (Returns_By_Ref (Function_Id)); pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); end Make_Build_In_Place_Call_In_Allocator; @@ -8662,6 +9084,7 @@ package body Exp_Ch6 is Set_Is_Expanded_Build_In_Place_Call (Func_Call); + pragma Assert (Returns_By_Ref (Function_Id)); pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); end if; @@ -8763,6 +9186,8 @@ package body Exp_Ch6 is Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl); Rewrite (Assign, Make_Null_Statement (Loc)); + + pragma Assert (Returns_By_Ref (Func_Id)); pragma Assert (Check_Number_Of_Actuals (Func_Call, Func_Id)); pragma Assert (Check_BIP_Actuals (Func_Call, Func_Id)); end Make_Build_In_Place_Call_In_Assignment; @@ -9187,6 +9612,7 @@ package body Exp_Ch6 is end if; end if; + pragma Assert (Returns_By_Ref (Function_Id)); pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); end Make_Build_In_Place_Call_In_Object_Declaration; @@ -9824,35 +10250,16 @@ package body Exp_Ch6 is => declare Call_Node : Node_Id renames Nod; - Subp : Entity_Id; + Subp : constant Entity_Id := Get_Called_Entity (Nod); begin - -- Call using access to subprogram with explicit dereference - - if Nkind (Name (Call_Node)) = N_Explicit_Dereference then - Subp := Etype (Name (Call_Node)); - - -- Prefix notation calls - - elsif Nkind (Name (Call_Node)) = N_Selected_Component then - Subp := Entity (Selector_Name (Name (Call_Node))); - - -- Call to member of entry family, where Name is an indexed - -- component, with the prefix being a selected component - -- giving the task and entry family name, and the index - -- being the entry index. - - elsif Nkind (Name (Call_Node)) = N_Indexed_Component then - Subp := - Entity (Selector_Name (Prefix (Name (Call_Node)))); + pragma Assert (Check_BIP_Actuals (Call_Node, Subp)); - -- Normal case + -- Build-in-place function calls return their result by + -- reference. - else - Subp := Entity (Name (Call_Node)); - end if; - - pragma Assert (Check_BIP_Actuals (Call_Node, Subp)); + pragma Assert (not Is_Build_In_Place_Function (Subp) + or else Returns_By_Ref (Subp)); end; -- Skip generic bodies diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 118d994..5919627 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -101,7 +101,20 @@ package Exp_Ch6 is -- Adds Extra_Actual as a named parameter association for the formal -- Extra_Formal in Subprogram_Call. + procedure Create_Extra_Actuals (Call_Node : Node_Id); + -- Create the extra actuals of the given call and add them to its + -- actual parameters list. + + procedure Apply_Access_Discrims_Accessibility_Check + (Exp : Node_Id; Func : Entity_Id); + -- Exp is an expression being returned from a function Func. + -- If the result type of the function has access discriminants, insert + -- checks that the accessibility level of each entity designated by an + -- access discriminant of the result is not deeper than the level of the + -- master of the call. + procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id); + -- Exp is an expression being returned from a function Func. -- Ada 2005 (AI95-344): If the result type is class-wide, insert a check -- that the level of the return expression's underlying type is not deeper -- than the level of the master enclosing the function. Always generate the diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 009bee4..dd864b7 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -59,6 +59,7 @@ with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Sem; use Sem; with Sem_Aux; use Sem_Aux; +with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; @@ -2331,6 +2332,8 @@ package body Exp_Ch7 is Ensure_Freeze_Node (Fin_Id); Insert_After (Fin_Spec, Freeze_Node (Fin_Id)); + Mutate_Ekind (Fin_Id, E_Procedure); + Freeze_Extra_Formals (Fin_Id); Set_Is_Frozen (Fin_Id); Append_To (Stmts, Fin_Body); @@ -3586,18 +3589,22 @@ package body Exp_Ch7 is procedure Build_Record_Deep_Procs (Typ : Entity_Id) is begin - Set_TSS (Typ, - Make_Deep_Proc - (Prim => Initialize_Case, - Typ => Typ, - Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); - - if not Is_Inherently_Limited_Type (Typ) then - Set_TSS (Typ, - Make_Deep_Proc - (Prim => Adjust_Case, - Typ => Typ, - Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); + if Has_Controlled_Component (Typ) then + Set_TSS + (Typ, + Make_Deep_Proc + (Prim => Initialize_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); + + if not Is_Inherently_Limited_Type (Typ) then + Set_TSS + (Typ, + Make_Deep_Proc + (Prim => Adjust_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); + end if; end if; -- Do not generate Deep_Finalize and Finalize_Address if finalization is @@ -5598,7 +5605,10 @@ package body Exp_Ch7 is -- Deal with untagged derivation of private views - if Present (Utyp) and then Is_Untagged_Derivation (Typ) then + if Present (Utyp) + and then Is_Untagged_Derivation (Typ) + and then Is_Implicit_Full_View (Utyp) + then Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); Ref := Unchecked_Convert_To (Utyp, Ref); Set_Assignment_OK (Ref); @@ -6635,6 +6645,16 @@ package body Exp_Ch7 is -- Raised : Boolean := False; -- -- begin + -- begin + -- <Destructor_Proc> (V); -- If applicable + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- end if; + -- end; + -- -- if F then -- begin -- Finalize (V); -- If applicable @@ -6690,6 +6710,8 @@ package body Exp_Ch7 is -- -- begin -- Deep_Finalize (V._parent, False); -- If applicable + -- or + -- Deep_Finalize (Parent_Type (V), False); -- Untagged case -- exception -- when Id : others => -- if not Raised then @@ -7094,7 +7116,7 @@ package body Exp_Ch7 is -- or the type is not controlled. if Is_Empty_List (Bod_Stmts) then - Append_To (Bod_Stmts, Make_Null_Statement (Loc)); + Append_New_To (Bod_Stmts, Make_Null_Statement (Loc)); return Bod_Stmts; @@ -7581,9 +7603,13 @@ package body Exp_Ch7 is -- Deep_Finalize (Obj._parent, False); - if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then + if Is_Derived_Type (Typ) then declare - Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); + Tagd : constant Boolean := Is_Tagged_Type (Typ); + Par_Typ : constant Entity_Id := + (if Tagd + then Parent_Field_Type (Typ) + else Etype (Base_Type (Typ))); Call : Node_Id; Fin_Stmt : Node_Id; @@ -7592,10 +7618,16 @@ package body Exp_Ch7 is Call := Make_Final_Call (Obj_Ref => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_V), - Selector_Name => - Make_Identifier (Loc, Name_uParent)), + (if Tagd + then + Make_Selected_Component + (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => + Make_Identifier (Loc, Name_uParent)) + else + Convert_To + (Par_Typ, Make_Identifier (Loc, Name_V))), Typ => Par_Typ, Skip_Self => True); @@ -7611,6 +7643,21 @@ package body Exp_Ch7 is -- Get_Current_Excep.all.all); -- end if; -- end; + -- + -- in the tagged case. In the untagged case, which arises + -- with the Destructor aspect, generate: + -- + -- begin + -- Deep_Finalize (Parent_Type (V), False); + + -- exception + -- when Id : others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, + -- Get_Current_Excep.all.all); + -- end if; + -- end; if Present (Call) then Fin_Stmt := Call; @@ -7656,7 +7703,7 @@ package body Exp_Ch7 is -- than before, the extension components. That might -- be more intuitive (as discussed in preceding -- comment), but it is not required. - Prepend_To (Bod_Stmts, Fin_Stmt); + Prepend_New_To (Bod_Stmts, Fin_Stmt); end if; end if; end if; @@ -7707,12 +7754,58 @@ package body Exp_Ch7 is (Finalizer_Data)))); end if; - Prepend_To (Bod_Stmts, + Prepend_New_To (Bod_Stmts, Make_If_Statement (Loc, Condition => Make_Identifier (Loc, Name_F), Then_Statements => New_List (Fin_Stmt))); end if; end; + + declare + ASN : constant Opt_N_Aspect_Specification_Id := + Get_Rep_Item (Typ, Name_Destructor, False); + + Stmt : Node_Id; + Proc : Entity_Id; + begin + if Present (ASN) then + -- Generate: + -- begin + -- <Destructor_Proc> (V); + + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, + -- Get_Current_Excep.all.all); + -- end if; + -- end; + + Proc := Entity (Expression (ASN)); + Stmt := + Make_Procedure_Call_Statement + (Loc, + Name => New_Occurrence_Of (Proc, Loc), + Parameter_Associations => + New_List (Make_Identifier (Loc, Name_V))); + if Exceptions_OK then + Stmt := + Make_Block_Statement + (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements + (Loc, + Statements => New_List (Stmt), + Exception_Handlers => + New_List + (Build_Exception_Handler + (Finalizer_Data)))); + end if; + + Prepend_New_To (Bod_Stmts, Stmt); + end if; + end; end if; -- At this point either all finalization statements have been @@ -7906,16 +7999,12 @@ package body Exp_Ch7 is if Is_Untagged_Derivation (Typ) then if Is_Protected_Type (Typ) then Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); + elsif Is_Implicit_Full_View (Utyp) then + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); - else - declare - Root : constant Entity_Id := - Underlying_Type (Root_Type (Base_Type (Typ))); - begin - if Is_Protected_Type (Root) then - Utyp := Corresponding_Record_Type (Root); - end if; - end; + if Is_Protected_Type (Utyp) then + Utyp := Corresponding_Record_Type (Utyp); + end if; end if; Ref := Unchecked_Convert_To (Utyp, Ref); @@ -7970,7 +8059,7 @@ package body Exp_Ch7 is return Empty; elsif Skip_Self then - if Has_Controlled_Component (Utyp) then + if Has_Controlled_Component (Utyp) or else Has_Destructor (Utyp) then if Is_Tagged_Type (Utyp) then Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); else @@ -7983,6 +8072,7 @@ package body Exp_Ch7 is elsif Is_Class_Wide_Type (Typ) or else Is_Interface (Typ) or else Has_Controlled_Component (Utyp) + or else Has_Destructor (Utyp) then if Is_Tagged_Type (Utyp) then Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); @@ -8480,7 +8570,10 @@ package body Exp_Ch7 is -- Deal with untagged derivation of private views - if Is_Untagged_Derivation (Typ) and then not Is_Conc then + if Is_Untagged_Derivation (Typ) + and then not Is_Conc + and then Is_Implicit_Full_View (Utyp) + then Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); Ref := Unchecked_Convert_To (Utyp, Ref); @@ -9448,9 +9541,16 @@ package body Exp_Ch7 is procedure Wrap_Transient_Expression (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Expr : Node_Id := Relocate_Node (N); - Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N); Typ : constant Entity_Id := Etype (N); + Temp : constant Entity_Id := Make_Temporary (Loc, 'E', + Related_Node => Expr); + -- We link the temporary with its relocated expression to facilitate + -- locating the expression in the expanded code; this simplifies the + -- implementation of the function that searchs in the expanded code + -- for a function call that has been wrapped in a transient block + -- (see Get_Relocated_Function_Call). + begin -- Generate: diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 9cfc6b5..c979cf6 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -4691,11 +4691,11 @@ package body Exp_Ch9 is -- The availability of the activation chain entity does not ensure -- that we have tasks to activate because it may have been declared - -- by the frontend to pass a required extra formal to a build-in-place + -- by the front end to pass a required extra formal to a build-in-place -- subprogram call. If we are within the scope of a protected type and -- pragma Detect_Blocking is active we can assume that no tasks will be -- activated; if tasks are created in a protected object and this pragma - -- is active then the frontend emits a warning and Program_Error is + -- is active then the front end emits a warning and Program_Error is -- raised at runtime. elsif Detect_Blocking and then Within_Protected_Type (Current_Scope) then @@ -8094,12 +8094,18 @@ package body Exp_Ch9 is -- access type. Finally the Entry_Component of each formal is set to -- reference the corresponding record component. - procedure Expand_N_Entry_Declaration (N : Node_Id) is + procedure Expand_N_Entry_Declaration + (N : Node_Id; + Was_Deferred : Boolean := False) + is + use Deferred_Extra_Formals_Support; + Loc : constant Source_Ptr := Sloc (N); Entry_Ent : constant Entity_Id := Defining_Identifier (N); Components : List_Id; Formal : Node_Id; Ftype : Entity_Id; + First_Decl : Node_Id; Last_Decl : Node_Id; Component : Entity_Id; Ctype : Entity_Id; @@ -8108,7 +8114,21 @@ package body Exp_Ch9 is Acc_Ent : Entity_Id; begin + -- No action if the addition of the extra formals was deferred, + -- since it means that the underlying type of some formal is not + -- available, and hence we cannot build the record type that will + -- hold all the parameter values. + + if Present (First_Formal (Entry_Ent)) + and then not Extra_Formals_Known (Entry_Ent) + and then not Is_Unsupported_Extra_Formals_Entity (Entry_Ent) + then + pragma Assert (Is_Deferred_Extra_Formals_Entity (Entry_Ent)); + return; + end if; + Formal := First_Formal (Entry_Ent); + First_Decl := N; Last_Decl := N; -- Most processing is done only if parameters are present @@ -8184,6 +8204,24 @@ package body Exp_Ch9 is Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc))); Insert_After (Last_Decl, Decl); + Last_Decl := Decl; + + -- Analyze all the inserted declarations. This is required when + -- the entry has formals and the addition of its extra formals + -- was deferred; otherwise their analysis will be performed as + -- as part of the regular flow of the front end at the end of + -- analysis of the enclosing task/protected type declaration. + + if Was_Deferred then + Push_Scope (Scope (Entry_Ent)); + + while First_Decl /= Last_Decl loop + Next (First_Decl); + Analyze (First_Decl); + end loop; + + End_Scope; + end if; end if; end Expand_N_Entry_Declaration; diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index cae6cb3..6811141 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -227,9 +227,16 @@ package Exp_Ch9 is procedure Expand_N_Delay_Until_Statement (N : Node_Id); procedure Expand_N_Entry_Body (N : Node_Id); procedure Expand_N_Entry_Call_Statement (N : Node_Id); - procedure Expand_N_Entry_Declaration (N : Node_Id); procedure Expand_N_Protected_Body (N : Node_Id); + procedure Expand_N_Entry_Declaration + (N : Node_Id; + Was_Deferred : Boolean := False); + -- Expands an entry declaration, building a record type to hold all the + -- parameter values. Was_Deferred is True when this expansion was deferred + -- because the underlying type of some formal was not available to build + -- the record. + procedure Expand_N_Protected_Type_Declaration (N : Node_Id); -- Expands protected type declarations. This results, among other things, -- in the declaration of a record type for the representation of protected diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 080a2e1..619ac40 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -801,7 +801,7 @@ package body Exp_Disp is -- No action needed if the dispatching call has been already expanded - or else Is_Expanded_Dispatching_Call (Name (Call_Node)) + or else Is_Expanded_Dispatching_Call (Call_Node) then return; end if; @@ -926,6 +926,8 @@ package body Exp_Disp is New_Formal : Entity_Id; Last_Formal : Entity_Id := Empty; + use Deferred_Extra_Formals_Support; + begin if Present (Old_Formal) then New_Formal := New_Copy (Old_Formal); @@ -962,51 +964,21 @@ package body Exp_Disp is end if; -- Now that the explicit formals have been duplicated, any extra - -- formals needed by the subprogram must be duplicated; we know - -- that extra formals are available because they were added when - -- the tagged type was frozen (see Expand_Freeze_Record_Type). + -- formals needed by the subprogram must be added; we know that + -- extra formals are available because they were added when the + -- tagged type was frozen (see Expand_Freeze_Record_Type). pragma Assert (Is_Frozen (Typ)); - -- Warning: The addition of the extra formals cannot be performed - -- here invoking Create_Extra_Formals since we must ensure that all - -- the extra formals of the pointer type and the target subprogram - -- match (and for functions that return a tagged type the profile of - -- the built subprogram type always returns a class-wide type, which - -- may affect the addition of some extra formals). - - if Present (Last_Formal) - and then Present (Extra_Formal (Last_Formal)) - then - Old_Formal := Extra_Formal (Last_Formal); - New_Formal := New_Copy (Old_Formal); - Set_Scope (New_Formal, Subp_Typ); - - Set_Extra_Formal (Last_Formal, New_Formal); - Set_Extra_Formals (Subp_Typ, New_Formal); - - if Ekind (Subp) = E_Function - and then Present (Extra_Accessibility_Of_Result (Subp)) - and then Extra_Accessibility_Of_Result (Subp) = Old_Formal - then - Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal); - end if; - - Old_Formal := Extra_Formal (Old_Formal); - while Present (Old_Formal) loop - Set_Extra_Formal (New_Formal, New_Copy (Old_Formal)); - New_Formal := Extra_Formal (New_Formal); - Set_Scope (New_Formal, Subp_Typ); + if Extra_Formals_Known (Subp) then + Create_Extra_Formals (Subp_Typ); - if Ekind (Subp) = E_Function - and then Present (Extra_Accessibility_Of_Result (Subp)) - and then Extra_Accessibility_Of_Result (Subp) = Old_Formal - then - Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal); - end if; + -- Extra formals were previously deferred - Old_Formal := Extra_Formal (Old_Formal); - end loop; + else + pragma Assert (Is_Deferred_Extra_Formals_Entity (Subp)); + Register_Deferred_Extra_Formals_Entity (Subp_Typ); + Register_Deferred_Extra_Formals_Call (Call_Node, Current_Scope); end if; end; @@ -1237,6 +1209,8 @@ package body Exp_Disp is -- the generation of spurious warnings under ZFP run-time. Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); + + Set_Is_Expanded_Dispatching_Call (Call_Node); end Expand_Dispatching_Call; --------------------------------- @@ -2378,17 +2352,6 @@ package body Exp_Disp is and then not Restriction_Active (No_Dispatching_Calls); end Has_DT; - ---------------------------------- - -- Is_Expanded_Dispatching_Call -- - ---------------------------------- - - function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is - begin - return Nkind (N) in N_Subprogram_Call - and then Nkind (Name (N)) = N_Explicit_Dereference - and then Is_Dispatch_Table_Entity (Etype (Name (N))); - end Is_Expanded_Dispatching_Call; - ------------------------------------- -- Is_Predefined_Dispatching_Alias -- ------------------------------------- @@ -8345,13 +8308,15 @@ package body Exp_Disp is Defining_Unit_Name => IP, Parameter_Specifications => Parms))); - Set_Init_Proc (Typ, IP); - Set_Is_Imported (IP); - Set_Is_Constructor (IP); - Set_Interface_Name (IP, Interface_Name (E)); - Set_Convention (IP, Convention_CPP); - Set_Is_Public (IP); - Set_Has_Completion (IP); + Set_Init_Proc (Typ, IP); + Set_Is_Imported (IP); + Set_Is_Constructor (IP); + Set_Interface_Name (IP, Interface_Name (E)); + Set_Convention (IP, Convention_CPP); + Set_Is_Public (IP); + Set_Has_Completion (IP); + Mutate_Ekind (IP, E_Procedure); + Freeze_Extra_Formals (IP); -- Case 2: Constructor of a tagged type @@ -8484,6 +8449,8 @@ package body Exp_Disp is Discard_Node (IP_Body); Set_Init_Proc (Typ, IP); + Mutate_Ekind (IP, E_Procedure); + Freeze_Extra_Formals (IP); end; end if; @@ -8549,6 +8516,8 @@ package body Exp_Disp is Discard_Node (IP_Body); Set_Init_Proc (Typ, IP); + Mutate_Ekind (IP, E_Procedure); + Freeze_Extra_Formals (IP); end; end if; diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 3cba8ca..76f5923 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -236,9 +236,6 @@ package Exp_Disp is function Has_CPP_Constructors (Typ : Entity_Id) return Boolean; -- Returns true if the type has CPP constructors - function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean; - -- Returns true if N is the expanded code of a dispatching call - function Make_DT (Typ : Entity_Id) return List_Id; -- Expand the declarations for the Dispatch Table of Typ diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index 40b2a65..ce3390b 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -77,8 +77,28 @@ package body Exp_Put_Image is -- reference). The Loc parameter is used as the Sloc of the created entity. function Put_Image_Base_Type (E : Entity_Id) return Entity_Id; - -- Returns the base type, except for an array type whose whose first - -- subtype is constrained, in which case it returns the first subtype. + -- For an array type whose whose first subtype is constrained, return + -- the first subtype. For the internal representation type corresponding + -- to a mutably tagged type, return the mutably tagged type. Otherwise, + -- return the base type. Similar to Exp_Strm.Stream_Base_Type. + + procedure Put_Specific_Type_Name_Qualifier + (Loc : Source_Ptr; + Stms : List_Id; + Tagged_Obj : Node_Id; + Buffer_Name : Node_Id; + Is_Interface_Type : Boolean); + -- Append to the given statement list calls to add into the + -- buffer the name of the given object's tag and then a "'". + + function Put_String_Exp_To_Buffer + (Loc : Source_Ptr; + String_Exp : Node_Id; + Buffer_Name : Node_Id; + Wide_Wide : Boolean := False) return Node_Id; + -- Generate a call to evaluate a String (or Wide_Wide_String, depending + -- on the Wide_Wide Boolean parameter) expression and output it into + -- the buffer. ------------------------------------- -- Build_Array_Put_Image_Procedure -- @@ -189,7 +209,7 @@ package body Exp_Put_Image is Ndim : constant Pos := Number_Dimensions (Typ); Ctyp : constant Entity_Id := Component_Type (Typ); - Stm : Node_Id; + Stms : List_Id := New_List; Exl : constant List_Id := New_List; PI_Entity : Entity_Id; @@ -220,15 +240,36 @@ package body Exp_Put_Image is Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', Dim))); end loop; - Stm := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Put_Image_Base_Type (Ctyp), Loc), - Attribute_Name => Name_Put_Image, - Expressions => New_List ( - Make_Identifier (Loc, Name_S), - Make_Indexed_Component (Loc, - Prefix => Make_Identifier (Loc, Name_V), - Expressions => Exl))); + declare + Ctype_For_Call : constant Entity_Id := Put_Image_Base_Type (Ctyp); + Indexed_Comp : constant Node_Id := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Expressions => Exl); + begin + if Is_Mutably_Tagged_Type (Ctype_For_Call) then + pragma Assert (not Is_Mutably_Tagged_Type (Component_Type (Typ))); + + Make_Mutably_Tagged_Conversion (Indexed_Comp, + Typ => Ctype_For_Call); + + pragma Assert (Is_Mutably_Tagged_Type (Etype (Indexed_Comp))); + + Put_Specific_Type_Name_Qualifier (Loc, + Stms => Stms, + Tagged_Obj => Indexed_Comp, + Buffer_Name => Make_Identifier (Loc, Name_S), + Is_Interface_Type => False); + end if; + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ctype_For_Call, Loc), + Attribute_Name => Name_Put_Image, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Indexed_Comp))); + end; -- The corresponding attribute for the component type of the array might -- be user-defined, and frozen after the array type. In that case, @@ -245,46 +286,42 @@ package body Exp_Put_Image is -- Loop through the dimensions, innermost first, generating a loop for -- each dimension. - declare - Stms : List_Id := New_List (Stm); - begin - for Dim in reverse 1 .. Ndim loop - declare - New_Stms : constant List_Id := New_List; - Between_Proc : RE_Id; - begin - -- For a one-dimensional array of elementary type, use - -- RE_Simple_Array_Between. The same applies to the last - -- dimension of a multidimensional array. + for Dim in reverse 1 .. Ndim loop + declare + New_Stms : constant List_Id := New_List; + Between_Proc : RE_Id; + begin + -- For a one-dimensional array of elementary type, use + -- RE_Simple_Array_Between. The same applies to the last + -- dimension of a multidimensional array. - if Is_Elementary_Type (Ctyp) and then Dim = Ndim then - Between_Proc := RE_Simple_Array_Between; - else - Between_Proc := RE_Array_Between; - end if; + if Is_Elementary_Type (Ctyp) and then Dim = Ndim then + Between_Proc := RE_Simple_Array_Between; + else + Between_Proc := RE_Array_Between; + end if; - Append_To (New_Stms, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Array_Before), Loc), - Parameter_Associations => New_List - (Make_Identifier (Loc, Name_S)))); + Append_To (New_Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Array_Before), Loc), + Parameter_Associations => New_List + (Make_Identifier (Loc, Name_S)))); - Append_To - (New_Stms, - Wrap_In_Loop (Stms, Dim, Indices (Dim), Between_Proc)); + Append_To + (New_Stms, + Wrap_In_Loop (Stms, Dim, Indices (Dim), Between_Proc)); - Append_To (New_Stms, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Array_After), Loc), - Parameter_Associations => New_List - (Make_Identifier (Loc, Name_S)))); + Append_To (New_Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Array_After), Loc), + Parameter_Associations => New_List + (Make_Identifier (Loc, Name_S)))); - Stms := New_Stms; - end; - end loop; + Stms := New_Stms; + end; + end loop; - Build_Put_Image_Proc (Loc, Typ, Decl, Pnam, Stms); - end; + Build_Put_Image_Proc (Loc, Typ, Decl, Pnam, Stms); end Build_Array_Put_Image_Procedure; ------------------------------------- @@ -379,7 +416,8 @@ package body Exp_Put_Image is begin -- We have built a dispatching call to handle calls to -- descendants (since they are not available through rtsfind). - -- Further details available in the body of Put_String_Exp. + -- Further details available in the body of + -- Put_String_Exp_To_Buffer. return Put_Call; end; @@ -691,19 +729,33 @@ package body Exp_Put_Image is --------------------------- procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id) is - Component_Typ : constant Entity_Id := - Put_Image_Base_Type - (Get_Corresponding_Mutably_Tagged_Type_If_Present (Etype (C))); + Component_Typ : constant Entity_Id := Put_Image_Base_Type (Etype (C)); + Selected_Comp : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (C, Loc)); begin + if Is_Mutably_Tagged_Type (Component_Typ) then + pragma Assert (not Is_Mutably_Tagged_Type (Etype (C))); + + Make_Mutably_Tagged_Conversion (Selected_Comp, + Typ => Component_Typ); + + pragma Assert (Is_Mutably_Tagged_Type (Etype (Selected_Comp))); + + Put_Specific_Type_Name_Qualifier (Loc, + Stms => Clist, + Tagged_Obj => Selected_Comp, + Buffer_Name => Make_Identifier (Loc, Name_S), + Is_Interface_Type => False); + end if; + Append_To (Clist, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Component_Typ, Loc), Attribute_Name => Name_Put_Image, - Expressions => New_List ( - Make_Identifier (Loc, Name_S), - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_V), - Selector_Name => New_Occurrence_Of (C, Loc))))); + Expressions => New_List (Make_Identifier (Loc, Name_S), + Selected_Comp))); end Append_Component_Attr; ------------------------------- @@ -1303,105 +1355,20 @@ package body Exp_Put_Image is New_Occurrence_Of (Sink_Entity, Loc)))); Actions : List_Id; - function Put_String_Exp (String_Exp : Node_Id; - Wide_Wide : Boolean := False) return Node_Id; - -- Generate a call to evaluate a String (or Wide_Wide_String, depending - -- on the Wide_Wide Boolean parameter) expression and output it into - -- the buffer. - - -------------------- - -- Put_String_Exp -- - -------------------- - - function Put_String_Exp (String_Exp : Node_Id; - Wide_Wide : Boolean := False) return Node_Id is - Put_Id : constant RE_Id := - (if Wide_Wide then RE_Wide_Wide_Put else RE_Put_UTF_8); - - -- We could build a nondispatching call here, but to make - -- that work we'd have to change Rtsfind spec to make available - -- corresponding callees out of Ada.Strings.Text_Buffers.Unbounded - -- (as opposed to from Ada.Strings.Text_Buffers). Seems simpler to - -- introduce a type conversion and leave it to the optimizer to - -- eliminate the dispatching. This does not *introduce* any problems - -- if a no-dispatching-allowed restriction is in effect, since we - -- are already in the middle of generating a call to T'Class'Image. - - Sink_Exp : constant Node_Id := - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of - (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc), - Expression => New_Occurrence_Of (Sink_Entity, Loc)); - begin - return - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (Put_Id), Loc), - Parameter_Associations => New_List (Sink_Exp, String_Exp)); - end Put_String_Exp; - - -- Local variables - - Tag_Node : Node_Id; - -- Start of processing for Build_Image_Call begin if Is_Class_Wide_Type (U_Type) then + Actions := New_List (Sink_Decl); - -- For interface types we must generate code to displace the pointer - -- to the object to reference the base of the underlying object. - - -- Generate: - -- To_Tag_Ptr (Image_Prefix'Address).all - - -- Note that Image_Prefix'Address is recursively expanded into a - -- call to Ada.Tags.Base_Address (Image_Prefix'Address). - - if Is_Interface (U_Type) then - Tag_Node := - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Image_Prefix), - Attribute_Name => Name_Address))); + Put_Specific_Type_Name_Qualifier (Loc, + Stms => Actions, + Tagged_Obj => Image_Prefix, + Buffer_Name => New_Occurrence_Of (Sink_Entity, Loc), + Is_Interface_Type => Is_Interface (U_Type)); - -- Common case - - else - Tag_Node := - Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Image_Prefix), - Attribute_Name => Name_Tag); - end if; - - -- Generate qualified-expression syntax; qualification name comes - -- from calling Ada.Tags.Wide_Wide_Expanded_Name. - - declare - -- The copy of Image_Prefix will be evaluated before the - -- original, which is ok if no side effects are involved. - - pragma Assert (Side_Effect_Free (Image_Prefix)); - - Specific_Type_Name : constant Node_Id := - Put_String_Exp - (Make_Function_Call (Loc, - Name => New_Occurrence_Of - (RTE (RE_Wide_Wide_Expanded_Name), Loc), - Parameter_Associations => New_List (Tag_Node)), - Wide_Wide => True); - - Qualification : constant Node_Id := - Put_String_Exp (Make_String_Literal (Loc, "'")); - begin - Actions := New_List - (Sink_Decl, - Specific_Type_Name, - Qualification, - Put_Im, - Result_Decl); - end; + Append_To (Actions, Put_Im); + Append_To (Actions, Result_Decl); else Actions := New_List (Sink_Decl, Put_Im, Result_Decl); end if; @@ -1485,9 +1452,89 @@ package body Exp_Put_Image is return E; elsif Is_Private_Type (Base_Type (E)) and not Is_Private_Type (E) then return Implementation_Base_Type (E); + elsif Is_Mutably_Tagged_CW_Equivalent_Type (E) then + return Get_Corresponding_Mutably_Tagged_Type_If_Present (E); else return Base_Type (E); end if; end Put_Image_Base_Type; + -------------------------------------- + -- Put_Specific_Type_Name_Qualifier -- + -------------------------------------- + + procedure Put_Specific_Type_Name_Qualifier + (Loc : Source_Ptr; + Stms : List_Id; + Tagged_Obj : Node_Id; + Buffer_Name : Node_Id; + Is_Interface_Type : Boolean) + is + Tag_Node : Node_Id; + begin + if Is_Interface_Type then + Tag_Node := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Tagged_Obj), + Attribute_Name => Name_Address))); + else + Tag_Node := + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Tagged_Obj), + Attribute_Name => Name_Tag); + end if; + + Append_To (Stms, + Put_String_Exp_To_Buffer (Loc, + String_Exp => + Make_Function_Call (Loc, + Name => New_Occurrence_Of + (RTE (RE_Wide_Wide_Expanded_Name), Loc), + Parameter_Associations => New_List (Tag_Node)), + Buffer_Name => Buffer_Name, + Wide_Wide => True)); + + Append_To (Stms, + Put_String_Exp_To_Buffer (Loc, + String_Exp => Make_String_Literal (Loc, "'"), + Buffer_Name => New_Copy_Tree (Buffer_Name))); + end Put_Specific_Type_Name_Qualifier; + + ------------------------------ + -- Put_String_Exp_To_Buffer -- + ------------------------------ + + function Put_String_Exp_To_Buffer + (Loc : Source_Ptr; + String_Exp : Node_Id; + Buffer_Name : Node_Id; + Wide_Wide : Boolean := False) return Node_Id + is + Put_Id : constant RE_Id := + (if Wide_Wide then RE_Wide_Wide_Put else RE_Put_UTF_8); + + -- We could build a nondispatching call here, but to make + -- that work we'd have to change Rtsfind spec to make available + -- corresponding callees out of Ada.Strings.Text_Buffers.Unbounded + -- (as opposed to from Ada.Strings.Text_Buffers). Seems simpler to + -- introduce a type conversion and leave it to the optimizer to + -- eliminate the dispatching. This does not *introduce* any problems + -- if a no-dispatching-allowed restriction is in effect, since we + -- are already in the middle of generating a call to T'Class'Image. + + Sink_Exp : constant Node_Id := + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc), + Expression => Buffer_Name); + begin + return + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (Put_Id), Loc), + Parameter_Associations => New_List (Sink_Exp, String_Exp)); + end Put_String_Exp_To_Buffer; + end Exp_Put_Image; diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index 6e1c86a..a75a507 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -73,6 +73,10 @@ package body Exp_SPARK is procedure Expand_SPARK_N_Attribute_Reference (N : Node_Id); -- Perform attribute-reference-specific expansion + procedure Expand_SPARK_N_Continue_Statement (N : Node_Id); + -- Expand continue statements which are resolved as procedure calls, into + -- said procedure calls. Real continue statements are left as-is. + procedure Expand_SPARK_N_Delta_Aggregate (N : Node_Id); -- Perform delta-aggregate-specific expansion @@ -191,6 +195,9 @@ package body Exp_SPARK is -- In SPARK mode, no other constructs require expansion + when N_Continue_Statement => + Expand_SPARK_N_Continue_Statement (N); + when others => null; end case; @@ -435,6 +442,23 @@ package body Exp_SPARK is end if; end Expand_SPARK_Delta_Or_Update; + --------------------------------------- + -- Expand_SPARK_N_Continue_Statement -- + --------------------------------------- + + procedure Expand_SPARK_N_Continue_Statement (N : Node_Id) is + X : constant Node_Id := Call_Or_Target_Loop (N); + begin + if No (X) then + return; + end if; + + if Nkind (X) = N_Procedure_Call_Statement then + Replace (N, X); + Analyze (N); + end if; + end Expand_SPARK_N_Continue_Statement; + ------------------------------ -- Expand_SPARK_N_Aggregate -- ------------------------------ diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 250efd2..5e1c913 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -29,6 +29,7 @@ with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Exp_Util; use Exp_Util; +with Mutably_Tagged; use Mutably_Tagged; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -101,13 +102,10 @@ package body Exp_Strm is -- Loc parameter is used as the Sloc of the created entity. function Stream_Base_Type (E : Entity_Id) return Entity_Id; - -- Stream attributes work on the basis of the base type except for the - -- array case. For the array case, we do not go to the base type, but - -- to the first subtype if it is constrained. This avoids problems with - -- incorrect conversions in the packed array case. Stream_Base_Type is - -- exactly this function (returns the base type, unless we have an array - -- type whose first subtype is constrained, in which case it returns the - -- first subtype). + -- For an array type whose whose first subtype is constrained, return + -- the first subtype. For the internal representation type corresponding + -- to a mutably tagged type, return the mutably tagged type. Otherwise, + -- return the base type. Similar to Exp_Put_Image.Put_Image_Base_Type. -------------------------------- -- Build_Array_Input_Function -- @@ -1502,6 +1500,7 @@ package body Exp_Strm is function Make_Field_Attribute (C : Entity_Id) return Node_Id is Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C)); + Selected : Node_Id; TSS_Names : constant array (Name_Input .. Name_Write) of TSS_Name_Type := @@ -1524,15 +1523,23 @@ package body Exp_Strm is return Make_Null_Statement (Loc); end if; + Selected := Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (C, Loc)); + + if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (C)) then + Make_Mutably_Tagged_Conversion + (Selected, + Typ => Get_Corresponding_Mutably_Tagged_Type_If_Present + (Etype (C))); + end if; + return Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Field_Typ, Loc), Attribute_Name => Nam, - Expressions => New_List ( - Make_Identifier (Loc, Name_S), - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_V), - Selector_Name => New_Occurrence_Of (C, Loc)))); + Expressions => New_List (Make_Identifier (Loc, Name_S), + Selected)); end Make_Field_Attribute; --------------------------- @@ -1808,6 +1815,10 @@ package body Exp_Strm is function Stream_Base_Type (E : Entity_Id) return Entity_Id is begin + if Is_Class_Wide_Equivalent_Type (E) then + return Corresponding_Mutably_Tagged_Type (E); + end if; + if Is_Array_Type (E) and then Is_First_Subtype (E) then diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 2172ce7..5a6fca0 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6189,18 +6189,12 @@ package body Exp_Util is if Is_Protected_Type (Btyp) then Utyp := Corresponding_Record_Type (Root_Type (Btyp)); - else - declare - Root : constant Entity_Id := Underlying_Type (Root_Type (Btyp)); - begin - if Is_Protected_Type (Root) then - Utyp := Corresponding_Record_Type (Root); - else - while No (TSS (Utyp, TSS_Finalize_Address)) loop - Utyp := Underlying_Type (Base_Type (Etype (Utyp))); - end loop; - end if; - end; + elsif Is_Implicit_Full_View (Utyp) then + Utyp := Underlying_Type (Root_Type (Btyp)); + + if Is_Protected_Type (Utyp) then + Utyp := Corresponding_Record_Type (Utyp); + end if; end if; end if; @@ -11736,34 +11730,6 @@ package body Exp_Util is end if; end Matching_Standard_Type; - ----------------------------- - -- May_Generate_Large_Temp -- - ----------------------------- - - -- At the current time, the only types that we return False for (i.e. where - -- we decide we know they cannot generate large temps) are ones where we - -- know the size is 256 bits or less at compile time, and we are still not - -- doing a thorough job on arrays and records. - - function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is - begin - if not Size_Known_At_Compile_Time (Typ) then - return False; - end if; - - if Known_Esize (Typ) and then Esize (Typ) <= 256 then - return False; - end if; - - if Is_Array_Type (Typ) - and then Present (Packed_Array_Impl_Type (Typ)) - then - return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ)); - end if; - - return True; - end May_Generate_Large_Temp; - --------------------------------------- -- Move_To_Initialization_Statements -- --------------------------------------- @@ -13766,11 +13732,12 @@ package body Exp_Util is -- The above requirements should be documented in Sinfo ??? function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is + Pexp : constant Node_Id := Parent (Exp); + Otyp : Entity_Id; Ityp : Entity_Id; Oalign : Uint; Ialign : Uint; - Pexp : constant Node_Id := Parent (Exp); begin -- If the expression is the RHS of an assignment or object declaration @@ -13788,18 +13755,12 @@ package body Exp_Util is return True; -- If the expression is the prefix of an N_Selected_Component we should - -- also be OK because GCC knows to look inside the conversion except if - -- the type is discriminated. We assume that we are OK anyway if the - -- type is not set yet or if it is controlled since we can't afford to - -- introduce a temporary in this case. + -- also be OK because GCC knows to look inside the conversion. elsif Nkind (Pexp) = N_Selected_Component and then Prefix (Pexp) = Exp then - return No (Etype (Pexp)) - or else not Is_Type (Etype (Pexp)) - or else not Has_Discriminants (Etype (Pexp)) - or else Is_Constrained (Etype (Pexp)); + return True; end if; -- Set the output type, this comes from Etype if it is set, otherwise we @@ -13872,14 +13833,7 @@ package body Exp_Util is -- known size, but we can't consider them that way here, because we are -- talking about the actual size of the object. - -- We also make sure that in addition to the size being known, we do not - -- have a case which might generate an embarrassingly large temp in - -- stack checking mode. - elsif Size_Known_At_Compile_Time (Otyp) - and then - (not Stack_Checking_Enabled - or else not May_Generate_Large_Temp (Otyp)) and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp)) then return True; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index b8b7525..4226fcc 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -1064,16 +1064,6 @@ package Exp_Util is -- typically return Standard_Short_Integer. For fixed-point types, this -- will return integer types of the corresponding size. - function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean; - -- Determines if the given type, Typ, may require a large temporary of the - -- kind that causes back-end trouble if stack checking is enabled. The - -- result is True only the size of the type is known at compile time and - -- large, where large is defined heuristically by the body of this routine. - -- The purpose of this routine is to help avoid generating troublesome - -- temporaries that interfere with stack checking mechanism. Note that the - -- caller has to check whether stack checking is actually enabled in order - -- to guide the expansion (typically of a function call). - procedure Move_To_Initialization_Statements (Decl, Stop : Node_Id); -- Decl is an N_Object_Declaration node and Stop is a node past Decl in -- the same list. Move all the nodes on the list between Decl and Stop diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 3755d9e..dbd7cf4 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -7231,6 +7231,35 @@ package body Freeze is end if; Inherit_Aspects_At_Freeze_Point (E); + + -- Destructor legality check + + if Present (Primitive_Operations (E)) then + declare + Subp : Entity_Id; + Parent_Operation : Entity_Id; + + Elmt : Elmt_Id := First_Elmt (Primitive_Operations (E)); + + begin + while Present (Elmt) loop + Subp := Node (Elmt); + + if Present (Overridden_Operation (Subp)) then + Parent_Operation := Overridden_Operation (Subp); + + if Ekind (Parent_Operation) = E_Procedure + and then Is_Destructor (Parent_Operation) + then + Error_Msg_N ("cannot override destructor", Subp); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + end if; -- Case of array type @@ -8130,6 +8159,7 @@ package body Freeze is if Ekind (E) = E_Anonymous_Access_Subprogram_Type and then Ekind (Designated_Type (E)) = E_Subprogram_Type then + Create_Extra_Formals (Designated_Type (E)); Layout_Type (Etype (Designated_Type (E))); end if; @@ -10393,6 +10423,8 @@ package body Freeze is -- Local variables + use Deferred_Extra_Formals_Support; + F : Entity_Id; Retype : Entity_Id; @@ -10493,8 +10525,11 @@ package body Freeze is Create_Extra_Formals (E); pragma Assert - ((Ekind (E) = E_Subprogram_Type - and then Extra_Formals_OK (E)) + ((Extra_Formals_Known (E) + or else Is_Deferred_Extra_Formals_Entity (E)) + or else + (Ekind (E) = E_Subprogram_Type + and then Extra_Formals_OK (E)) or else (Is_Subprogram (E) and then Extra_Formals_OK (E) @@ -10523,6 +10558,10 @@ package body Freeze is else Set_Mechanisms (E); + if not Extra_Formals_Known (E) then + Freeze_Extra_Formals (E); + end if; + -- For foreign conventions, warn about return of unconstrained array if Ekind (E) = E_Function then @@ -10578,6 +10617,11 @@ package body Freeze is end if; end if; + -- Check formals matching in thunks + + pragma Assert (not Is_Thunk (E) + or else Extra_Formals_Match_OK (Thunk_Entity (E), E)); + -- Pragma Inline_Always is disallowed for dispatching subprograms -- because the address of such subprograms is saved in the dispatch -- table to support dispatching calls, and dispatching calls cannot diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc index 128040e..7711f8b 100644 --- a/gcc/ada/gcc-interface/misc.cc +++ b/gcc/ada/gcc-interface/misc.cc @@ -271,7 +271,7 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) /* No caret by default for Ada. */ if (!OPTION_SET_P (flag_diagnostics_show_caret)) - global_dc->m_source_printing.enabled = false; + global_dc->get_source_printing_options ().enabled = false; /* Copy global settings to local versions. */ gnat_encodings = global_options.x_gnat_encodings; @@ -292,7 +292,7 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) /* Here is the function to handle the compiler error processing in GCC. */ static void -internal_error_function (diagnostic_context *context, const char *msgid, +internal_error_function (diagnostics::context *context, const char *msgid, va_list *ap) { char *buffer, *p, *loc; diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index a7254fe..fd1d39c 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -1510,7 +1510,7 @@ Pragma_to_gnu (Node_Id gnat_node) const location_t location = input_location; struct cl_option_handlers handlers; unsigned int option_index; - diagnostic_t kind; + enum diagnostics::kind kind; bool imply; gnat_temp = First (Pragma_Argument_Associations (gnat_node)); @@ -1521,12 +1521,12 @@ Pragma_to_gnu (Node_Id gnat_node) switch (id) { case Pragma_Warning_As_Error: - kind = DK_ERROR; + kind = diagnostics::kind::error; imply = false; break; case Pragma_Warnings: - kind = DK_WARNING; + kind = diagnostics::kind::warning; imply = true; break; @@ -1543,11 +1543,11 @@ Pragma_to_gnu (Node_Id gnat_node) switch (Chars (Expression (gnat_temp))) { case Name_Off: - kind = DK_IGNORED; + kind = diagnostics::kind::ignored; break; case Name_On: - kind = DK_WARNING; + kind = diagnostics::kind::warning; break; default: @@ -1569,7 +1569,7 @@ Pragma_to_gnu (Node_Id gnat_node) gnat_expr = Empty; /* For pragma Warnings (Off), we save the current state... */ - if (kind == DK_IGNORED) + if (kind == diagnostics::kind::ignored) diagnostic_push_diagnostics (global_dc, location); /* ...so that, for pragma Warnings (On), we do not enable all @@ -8476,7 +8476,8 @@ gnat_to_gnu (Node_Id gnat_node) oconstraints[i] = constraint; if (parse_output_constraint (&constraint, i, ninputs, noutputs, - &allows_mem, &allows_reg, &fake)) + &allows_mem, &allows_reg, &fake, + nullptr)) { /* If the operand is going to end up in memory, mark it addressable. Note that we don't test @@ -8504,9 +8505,9 @@ gnat_to_gnu (Node_Id gnat_node) constraint = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail))); - if (parse_input_constraint (&constraint, i, ninputs, noutputs, - 0, oconstraints, - &allows_mem, &allows_reg)) + if (parse_input_constraint (&constraint, i, ninputs, noutputs, 0, + oconstraints, &allows_mem, + &allows_reg, nullptr)) { /* If the operand is going to end up in memory, mark it addressable. */ @@ -8752,7 +8753,7 @@ gnat_to_gnu (Node_Id gnat_node) /* Set the location information on the result if it's not a simple name or something that contains a simple name, for example a tag, because - we don"t want all the references to get the location of the first use. + we don't want all the references to get the location of the first use. Note that we may have no result if we tried to build a CALL_EXPR node to a procedure with no side-effects and optimization is enabled. */ else if (kind != N_Identifier diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index 7324bee..f501915 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -4510,8 +4510,8 @@ build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, void update_pointer_to (tree old_type, tree new_type) { - tree ptr = TYPE_POINTER_TO (old_type); - tree ref = TYPE_REFERENCE_TO (old_type); + const tree old_ptr = TYPE_POINTER_TO (old_type); + const tree old_ref = TYPE_REFERENCE_TO (old_type); tree t; /* If this is the main variant, process all the other variants first. */ @@ -4520,7 +4520,7 @@ update_pointer_to (tree old_type, tree new_type) update_pointer_to (t, new_type); /* If no pointers and no references, we are done. */ - if (!ptr && !ref) + if (!old_ptr && !old_ref) return; /* Merge the old type qualifiers in the new type. @@ -4554,12 +4554,13 @@ update_pointer_to (tree old_type, tree new_type) if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE) { tree new_ptr, new_ref; + tree ptr, ref; /* If pointer or reference already points to new type, nothing to do. This can happen as update_pointer_to can be invoked multiple times on the same couple of types because of the type variants. */ - if ((ptr && TREE_TYPE (ptr) == new_type) - || (ref && TREE_TYPE (ref) == new_type)) + if ((old_ptr && TREE_TYPE (old_ptr) == new_type) + || (old_ref && TREE_TYPE (old_ref) == new_type)) return; /* Chain PTR and its variants at the end. */ @@ -4568,13 +4569,13 @@ update_pointer_to (tree old_type, tree new_type) { while (TYPE_NEXT_PTR_TO (new_ptr)) new_ptr = TYPE_NEXT_PTR_TO (new_ptr); - TYPE_NEXT_PTR_TO (new_ptr) = ptr; + TYPE_NEXT_PTR_TO (new_ptr) = old_ptr; } else - TYPE_POINTER_TO (new_type) = ptr; + TYPE_POINTER_TO (new_type) = old_ptr; /* Now adjust them. */ - for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr)) + for (ptr = old_ptr; ptr; ptr = TYPE_NEXT_PTR_TO (ptr)) for (t = TYPE_MAIN_VARIANT (ptr); t; t = TYPE_NEXT_VARIANT (t)) { TREE_TYPE (t) = new_type; @@ -4589,13 +4590,13 @@ update_pointer_to (tree old_type, tree new_type) { while (TYPE_NEXT_REF_TO (new_ref)) new_ref = TYPE_NEXT_REF_TO (new_ref); - TYPE_NEXT_REF_TO (new_ref) = ref; + TYPE_NEXT_REF_TO (new_ref) = old_ref; } else - TYPE_REFERENCE_TO (new_type) = ref; + TYPE_REFERENCE_TO (new_type) = old_ref; /* Now adjust them. */ - for (; ref; ref = TYPE_NEXT_REF_TO (ref)) + for (ref = old_ref; ref; ref = TYPE_NEXT_REF_TO (ref)) for (t = TYPE_MAIN_VARIANT (ref); t; t = TYPE_NEXT_VARIANT (t)) { TREE_TYPE (t) = new_type; @@ -4614,20 +4615,20 @@ update_pointer_to (tree old_type, tree new_type) { tree new_ptr = TYPE_POINTER_TO (new_type); - gcc_assert (TYPE_IS_FAT_POINTER_P (ptr)); + gcc_assert (TYPE_IS_FAT_POINTER_P (old_ptr)); /* If PTR already points to NEW_TYPE, nothing to do. This can happen since update_pointer_to can be invoked multiple times on the same couple of types because of the type variants. */ - if (TYPE_UNCONSTRAINED_ARRAY (ptr) == new_type) + if (TYPE_UNCONSTRAINED_ARRAY (old_ptr) == new_type) return; update_pointer_to - (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))), + (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (old_ptr))), TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr)))); update_pointer_to - (TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (ptr)))), + (TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (old_ptr)))), TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (new_ptr))))); update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 2d16e12..a1e284f 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -255,6 +255,7 @@ package Gen_IL.Fields is Is_Entry_Barrier_Function, Is_Expanded_Build_In_Place_Call, Is_Expanded_Constructor_Call, + Is_Expanded_Dispatching_Call, Is_Expanded_Prefixed_Call, Is_Folded_In_Parser, Is_Generic_Contract_Pragma, @@ -400,6 +401,7 @@ package Gen_IL.Fields is Suppress_Loop_Warnings, Synchronized_Present, Tagged_Present, + Tag_Propagated, Target, Call_Or_Target_Loop, Target_Type, @@ -539,6 +541,7 @@ package Gen_IL.Fields is Extra_Constrained, Extra_Formal, Extra_Formals, + Extra_Formals_Known, Finalization_Collection, Finalization_Master_Node, Finalize_Storage_Only, @@ -572,6 +575,7 @@ package Gen_IL.Fields is Has_Delayed_Aspects, Has_Delayed_Freeze, Has_Delayed_Rep_Aspects, + Has_Destructor, Has_Discriminants, Has_Dispatch_Table, Has_Dynamic_Predicate_Aspect, @@ -699,6 +703,7 @@ package Gen_IL.Fields is Is_CPP_Class, Is_CUDA_Kernel, Is_Descendant_Of_Address, + Is_Destructor, Is_DIC_Procedure, Is_Discrim_SO_Function, Is_Discriminant_Check_Function, @@ -730,6 +735,7 @@ package Gen_IL.Fields is Is_Ignored_Ghost_Entity, Is_Immediately_Visible, Is_Implementation_Defined, + Is_Implicit_Full_View, Is_Imported, Is_Independent, Is_Initial_Condition_Procedure, @@ -850,6 +856,7 @@ package Gen_IL.Fields is Original_Protected_Subprogram, Original_Record_Component, Overlays_Constant, + Overridden_Inherited_Operation, Overridden_Operation, Package_Instantiation, Packed_Array_Impl_Type, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 8cbed8a..0fedfbc 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -467,6 +467,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Full_View, Node_Id), Sm (Has_Completion_In_Body, Flag), Sm (Has_Constrained_Partial_View, Flag, Base_Type_Only), + Sm (Has_Destructor, Flag, Base_Type_Only), Sm (Has_Discriminants, Flag), Sm (Has_Dispatch_Table, Flag, Pre => "Is_Tagged_Type (N)"), @@ -502,6 +503,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Fixed_Lower_Bound_Array_Subtype, Flag), Sm (Is_Fixed_Lower_Bound_Index_Subtype, Flag), Sm (Is_Generic_Actual_Type, Flag), + Sm (Is_Implicit_Full_View, Flag), Sm (Is_Mutably_Tagged_Type, Flag), Sm (Is_Non_Static_Subtype, Flag), Sm (Is_Private_Composite, Flag), @@ -935,11 +937,13 @@ begin -- Gen_IL.Gen.Gen_Entities (Sm (Access_Subprogram_Wrapper, Node_Id), Sm (Extra_Accessibility_Of_Result, Node_Id), Sm (Extra_Formals, Node_Id), + Sm (Extra_Formals_Known, Flag), Sm (Needs_No_Actuals, Flag))); Ab (Overloadable_Kind, Entity_Kind, (Sm (Renamed_Or_Alias, Node_Id), Sm (Extra_Formals, Node_Id), + Sm (Extra_Formals_Known, Flag), Sm (Is_Abstract_Subprogram, Flag), Sm (Is_Primitive, Flag), Sm (Needs_No_Actuals, Flag), @@ -953,6 +957,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Enumeration_Rep_Expr, Node_Id), Sm (Esize, Uint), Sm (Alignment, Unat), + Sm (Overridden_Inherited_Operation, Node_Id), Sm (Interface_Name, Node_Id))); Ab (Subprogram_Kind, Overloadable_Kind, @@ -981,6 +986,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Machine_Code_Subprogram, Flag), Sm (Last_Entity, Node_Id), Sm (Linker_Section_Pragma, Node_Id), + Sm (Overridden_Inherited_Operation, Node_Id), Sm (Overridden_Operation, Node_Id), Sm (Protected_Body_Subprogram, Node_Id), Sm (No_Raise, Flag), @@ -1050,6 +1056,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Asynchronous, Flag), Sm (Is_Called, Flag), Sm (Is_CUDA_Kernel, Flag), + Sm (Is_Destructor, Flag), Sm (Is_DIC_Procedure, Flag), Sm (Is_Generic_Actual_Subprogram, Flag), Sm (Is_Initial_Condition_Procedure, Flag), @@ -1125,6 +1132,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Entry_Accepted, Flag), Sm (Entry_Parameters_Type, Node_Id), Sm (Extra_Formals, Node_Id), + Sm (Extra_Formals_Known, Flag), Sm (First_Entity, Node_Id), Sm (Has_Out_Or_In_Out_Parameter, Flag), Sm (Ignore_SPARK_Mode_Pragmas, Flag), @@ -1326,6 +1334,7 @@ begin -- Gen_IL.Gen.Gen_Entities (Sm (Anonymous_Collections, Elist_Id), Sm (Contract, Node_Id), Sm (Extra_Formals, Node_Id), + Sm (Extra_Formals_Known, Flag), Sm (First_Entity, Node_Id), Sm (Ignore_SPARK_Mode_Pragmas, Flag), Sm (Interface_Name, Node_Id), diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index f4e7917..412565f 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -149,6 +149,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Is_Controlling_Actual, Flag), Sm (Is_Overloaded, Flag), Sm (Is_Static_Expression, Flag), + Sm (Is_Expanded_Dispatching_Call, Flag), Sm (Must_Not_Freeze, Flag), Sm (Raises_Constraint_Error, Flag))); @@ -181,7 +182,8 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Is_Elaboration_Warnings_OK_Node, Flag), Sm (Is_SPARK_Mode_On_Node, Flag), Sm (Original_Discriminant, Node_Id), - Sm (Redundant_Use, Flag))); + Sm (Redundant_Use, Flag), + Sm (Tag_Propagated, Flag))); Cc (N_Operator_Symbol, N_Direct_Name, (Sy (Strval, String_Id))); @@ -346,7 +348,8 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sy (Prefix, Node_Id), Sm (Actual_Designated_Subtype, Node_Id), Sm (Atomic_Sync_Required, Flag), - Sm (Has_Dereference_Action, Flag))); + Sm (Has_Dereference_Action, Flag), + Sm (Tag_Propagated, Flag))); Cc (N_Expression_With_Actions, N_Subexpr, (Sy (Actions, List_Id, Default_No_List), @@ -463,6 +466,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Do_Length_Check, Flag), Sm (Do_Overflow_Check, Flag), Sm (Float_Truncate, Flag), + Sm (Tag_Propagated, Flag), Sm (Rounded_Result, Flag))); Cc (N_Unchecked_Type_Conversion, N_Subexpr, @@ -905,6 +909,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Cleanup_Actions, List_Id), Sm (Exception_Junk, Flag), Sm (Is_Abort_Block, Flag), + Sm (Is_Expanded_Dispatching_Call, Flag), Sm (Is_Initialization_Block, Flag), Sm (Is_Task_Master, Flag))); diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb index 8d0dfc7..3fa8b94 100644 --- a/gcc/ada/gen_il-internals.adb +++ b/gcc/ada/gen_il-internals.adb @@ -277,6 +277,8 @@ package body Gen_IL.Internals is return "DT_Offset_To_Top_Func"; when DT_Position => return "DT_Position"; + when Extra_Formals_Known => + return "Extra_Formals_Known"; when Forwards_OK => return "Forwards_OK"; when Has_First_Controlling_Parameter_Aspect => diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index b0a14b0..5d7bedc 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Jul 03, 2025 +GNAT Reference Manual , Jul 24, 2025 AdaCore @@ -931,6 +931,7 @@ Experimental Language Extensions * External_Initialization Aspect:: * Finally construct:: * Continue statement:: +* Destructors:: Storage Model @@ -13071,9 +13072,9 @@ pragma Export (C, Last_Chance_Handler, "__gnat_last_chance_handler"); @end example -The parameter is a C null-terminated string representing a message to be -associated with the exception (typically the source location of the raise -statement generated by the compiler). The Line parameter when nonzero +The @code{Source_Location} parameter is a C null-terminated string representing a +message to be associated with the exception (typically the source location of +the raise statement generated by the compiler). The Line parameter when nonzero represents the line number in the source program where the raise occurs. @node No_Exception_Propagation,No_Exception_Registration,No_Exception_Handlers,Partition-Wide Restrictions @@ -31236,6 +31237,7 @@ Features activated via @code{-gnatX0} or * External_Initialization Aspect:: * Finally construct:: * Continue statement:: +* Destructors:: @end menu @@ -32588,7 +32590,7 @@ Abort/ATC (asynchronous transfer of control) cannot interrupt a finally block, n execution, that is the finally block must be executed in full even if the containing task is aborted, or if the control is transferred out of the block. -@node Continue statement,,Finally construct,Experimental Language Extensions +@node Continue statement,Destructors,Finally construct,Experimental Language Extensions @anchor{gnat_rm/gnat_language_extensions continue-statement}@anchor{472} @subsection Continue statement @@ -32606,8 +32608,78 @@ statement in the sequence of statements of the specified loop_statement. Note that @code{continue} is a keyword but it is not a reserved word. This is a configuration that does not exist in standard Ada. +@node Destructors,,Continue statement,Experimental Language Extensions +@anchor{gnat_rm/gnat_language_extensions destructors}@anchor{473} +@subsection Destructors + + +The @code{Destructor} aspect can be applied to any record type, tagged or not. +It must denote a primitive of the type that is a procedure with one parameter +of the type and of mode @code{in out}: + +@example +type T is record + ... +end record with Destructor => Foo; + +procedure Foo (X : in out T); +@end example + +This is equivalent to the following code that uses @code{Finalizable}: + +@example +type T is record + ... +end record with Finalizable => (Finalize => Foo); + +procedure Foo (X : in out T); +@end example + +Unlike @code{Finalizable}, however, @code{Destructor} can be specified on a derived +type. And when it is, the effect of the aspect combines with the destructors of +the parent type. Take, for example: + +@example +type T1 is record + ... +end record with Destructor => Foo; + +procedure Foo (X : in out T1); + +type T2 is new T1 with Destructor => Bar; + +procedure Bar (X : in out T2); +@end example + +Here, when an object of type @code{T2} is finalized, a call to @code{Bar} +will be performed and it will be followed by a call to @code{Foo}. + +The @code{Destructor} aspect comes with a legality rule: if a primitive procedure +of a type is denoted by a @code{Destructor} aspect specification, it is illegal to +override this procedure in a derived type. For example, the following is illegal: + +@example +type T1 is record + ... +end record with Destructor => Foo; + +procedure Foo (X : in out T1); + +type T2 is new T1; + +overriding +procedure Foo (X : in out T2); -- Error here +@end example + +It is possible to specify @code{Destructor} on the completion of a private type, +but there is one more restriction in that case: the denoted primitive must +be private to the enclosing package. This is necessary due to the previously +mentioned legality rule, to prevent breaking the privacy of the type when +imposing that rule on outside types that derive from the private view of the +type. + @node Security Hardening Features,Obsolescent Features,GNAT language extensions,Top -@anchor{gnat_rm/security_hardening_features doc}@anchor{473}@anchor{gnat_rm/security_hardening_features id1}@anchor{474}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} +@anchor{gnat_rm/security_hardening_features doc}@anchor{474}@anchor{gnat_rm/security_hardening_features id1}@anchor{475}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} @chapter Security Hardening Features @@ -32629,7 +32701,7 @@ change. @end menu @node Register Scrubbing,Stack Scrubbing,,Security Hardening Features -@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{475} +@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{476} @section Register Scrubbing @@ -32665,7 +32737,7 @@ programming languages, see @cite{Using the GNU Compiler Collection (GCC)}. @c Stack Scrubbing: @node Stack Scrubbing,Hardened Conditionals,Register Scrubbing,Security Hardening Features -@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{476} +@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{477} @section Stack Scrubbing @@ -32809,7 +32881,7 @@ Bar_Callable_Ptr. @c Hardened Conditionals: @node Hardened Conditionals,Hardened Booleans,Stack Scrubbing,Security Hardening Features -@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{477} +@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{478} @section Hardened Conditionals @@ -32899,7 +32971,7 @@ be used with other programming languages supported by GCC. @c Hardened Booleans: @node Hardened Booleans,Control Flow Redundancy,Hardened Conditionals,Security Hardening Features -@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{478} +@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{479} @section Hardened Booleans @@ -32960,7 +33032,7 @@ and more details on that attribute, see @cite{Using the GNU Compiler Collection @c Control Flow Redundancy: @node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features -@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{479} +@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{47a} @section Control Flow Redundancy @@ -33128,7 +33200,7 @@ see @cite{Using the GNU Compiler Collection (GCC)}. These options can be used with other programming languages supported by GCC. @node Obsolescent Features,Compatibility and Porting Guide,Security Hardening Features,Top -@anchor{gnat_rm/obsolescent_features doc}@anchor{47a}@anchor{gnat_rm/obsolescent_features id1}@anchor{47b}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} +@anchor{gnat_rm/obsolescent_features doc}@anchor{47b}@anchor{gnat_rm/obsolescent_features id1}@anchor{47c}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} @chapter Obsolescent Features @@ -33147,7 +33219,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{47c}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{47d} +@anchor{gnat_rm/obsolescent_features id2}@anchor{47d}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{47e} @section pragma No_Run_Time @@ -33160,7 +33232,7 @@ preferred usage is to use an appropriately configured run-time that includes just those features that are to be made accessible. @node pragma Ravenscar,pragma Restricted_Run_Time,pragma No_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id3}@anchor{47e}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{47f} +@anchor{gnat_rm/obsolescent_features id3}@anchor{47f}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{480} @section pragma Ravenscar @@ -33169,7 +33241,7 @@ The pragma @code{Ravenscar} has exactly the same effect as pragma is part of the new Ada 2005 standard. @node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id4}@anchor{480}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{481} +@anchor{gnat_rm/obsolescent_features id4}@anchor{481}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{482} @section pragma Restricted_Run_Time @@ -33179,7 +33251,7 @@ preferred since the Ada 2005 pragma @code{Profile} is intended for this kind of implementation dependent addition. @node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id5}@anchor{482}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{483} +@anchor{gnat_rm/obsolescent_features id5}@anchor{483}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{484} @section pragma Task_Info @@ -33205,7 +33277,7 @@ in the spec of package System.Task_Info in the runtime library. @node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features -@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{484}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{485} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{485}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{486} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -33215,7 +33287,7 @@ to support the @code{Task_Info} pragma. The predefined Ada package standard replacement for GNAT’s @code{Task_Info} functionality. @node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top -@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{486}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{487} +@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{487}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{488} @chapter Compatibility and Porting Guide @@ -33237,7 +33309,7 @@ applications developed in other Ada environments. @end menu @node Writing Portable Fixed-Point Declarations,Compatibility with Ada 83,,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{488}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{489} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{489}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{48a} @section Writing Portable Fixed-Point Declarations @@ -33359,7 +33431,7 @@ If you follow this scheme you will be guaranteed that your fixed-point types will be portable. @node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{48a}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{48b} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{48b}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{48c} @section Compatibility with Ada 83 @@ -33387,7 +33459,7 @@ following subsections treat the most likely issues to be encountered. @end menu @node Legal Ada 83 programs that are illegal in Ada 95,More deterministic semantics,,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{48c}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{48d} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{48d}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{48e} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -33487,7 +33559,7 @@ the fix is usually simply to add the @code{(<>)} to the generic declaration. @end itemize @node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{48e}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{48f} +@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{48f}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{490} @subsection More deterministic semantics @@ -33515,7 +33587,7 @@ which open select branches are executed. @end itemize @node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{490}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{491} +@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{491}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{492} @subsection Changed semantics @@ -33557,7 +33629,7 @@ covers only the restricted range. @end itemize @node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{492}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{493} +@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{493}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{494} @subsection Other language compatibility issues @@ -33590,7 +33662,7 @@ include @code{pragma Interface} and the floating point type attributes @end itemize @node Compatibility between Ada 95 and Ada 2005,Implementation-dependent characteristics,Compatibility with Ada 83,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{494}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{495} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{495}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{496} @section Compatibility between Ada 95 and Ada 2005 @@ -33662,7 +33734,7 @@ can declare a function returning a value from an anonymous access type. @end itemize @node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{496}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{497} +@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{497}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{498} @section Implementation-dependent characteristics @@ -33685,7 +33757,7 @@ transition from certain Ada 83 compilers. @end menu @node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{498}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{499} +@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{499}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{49a} @subsection Implementation-defined pragmas @@ -33707,7 +33779,7 @@ avoiding compiler rejection of units that contain such pragmas; they are not relevant in a GNAT context and hence are not otherwise implemented. @node Implementation-defined attributes,Libraries,Implementation-defined pragmas,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{49a}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{49b} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{49b}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{49c} @subsection Implementation-defined attributes @@ -33721,7 +33793,7 @@ Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and @code{Type_Class}. @node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{49c}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{49d} +@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{49d}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{49e} @subsection Libraries @@ -33750,7 +33822,7 @@ be preferable to retrofit the application using modular types. @end itemize @node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{49e}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{49f} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{49f}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{4a0} @subsection Elaboration order @@ -33786,7 +33858,7 @@ pragmas either globally (as an effect of the `-gnatE' switch) or locally @end itemize @node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{4a0}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{4a1} +@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{4a1}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{4a2} @subsection Target-specific aspects @@ -33799,10 +33871,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus Ada 2005, Ada 2012, and Ada 2022) are sometimes incompatible with typical Ada 83 compiler practices regarding implicit packing, the meaning of the Size attribute, and the size of access values. -GNAT’s approach to these issues is described in @ref{4a2,,Representation Clauses}. +GNAT’s approach to these issues is described in @ref{4a3,,Representation Clauses}. @node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{4a3}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{4a4} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{4a4}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{4a5} @section Compatibility with Other Ada Systems @@ -33845,7 +33917,7 @@ far beyond this minimal set, as described in the next section. @end itemize @node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{4a5}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{4a2} +@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{4a6}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{4a3} @section Representation Clauses @@ -33938,7 +34010,7 @@ with thin pointers. @end itemize @node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{4a6}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{4a7} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{4a7}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{4a8} @section Compatibility with HP Ada 83 @@ -33968,7 +34040,7 @@ extension of package System. @end itemize @node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top -@anchor{share/gnu_free_documentation_license doc}@anchor{4a8}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{4a9} +@anchor{share/gnu_free_documentation_license doc}@anchor{4a9}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{4aa} @chapter GNU Free Documentation License diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h index 79836e8..5a553d1 100644 --- a/gcc/ada/gsocket.h +++ b/gcc/ada/gsocket.h @@ -64,6 +64,12 @@ #include <ioLib.h> #include <hostLib.h> +#if __has_include ("strings.h") +/* On VxWorks6, FD_ZERO uses bzero, but since it's not a standard header, don't + require it. */ +#include "strings.h" +#endif + #define SHUT_RD 0 #define SHUT_WR 1 #define SHUT_RDWR 2 diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index e8eeebd..5e2f033 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -3797,6 +3797,17 @@ package body Inline is and then Is_Unc; end if; + -- Inlining function calls returning an object of unconstrained type as + -- function actuals or in a return statement is not supported: a + -- temporary variable will be declared of unconstrained type without + -- initializing expression. + + pragma Assert + (not Uses_Back_End + or else Nkind (Parent (N)) not in + N_Function_Call | N_Simple_Return_Statement + or else not Is_Unc); + -- Check for an illegal attempt to inline a recursive procedure. If the -- subprogram has parameters this is detected when trying to supply a -- binding for parameters that already have one. For parameterless diff --git a/gcc/ada/libgnat/a-calend.adb b/gcc/ada/libgnat/a-calend.adb index 4f89a40..0be5673 100644 --- a/gcc/ada/libgnat/a-calend.adb +++ b/gcc/ada/libgnat/a-calend.adb @@ -1068,19 +1068,28 @@ is tv_nsec : out Long_Integer) is pragma Unsuppress (Overflow_Check); - Secs : Duration; - Nano_Secs : Duration; begin - -- Seconds extraction, avoid potential rounding errors - - Secs := D - 0.5; - tv_sec := Long_Long_Integer (Secs); - - -- Nanoseconds extraction + if D = 0.0 then + tv_sec := 0; + tv_nsec := 0; + + elsif D < 0.0 then + tv_sec := Long_Long_Integer (D + 0.5); + if D = Duration (tv_sec) then + tv_nsec := 0; + else + tv_nsec := Long_Integer ((D - Duration (tv_sec)) * Nano + 0.5); + end if; - Nano_Secs := D - Duration (tv_sec); - tv_nsec := Long_Integer (Nano_Secs * Nano); + else + tv_sec := Long_Long_Integer (D - 0.5); + if D = Duration (tv_sec) then + tv_nsec := 0; + else + tv_nsec := Long_Integer ((D - Duration (tv_sec)) * Nano - 0.5); + end if; + end if; end To_Struct_Timespec_64; ------------------ diff --git a/gcc/ada/libgnat/a-cbhama.adb b/gcc/ada/libgnat/a-cbhama.adb index ee6584d..b2d7964 100644 --- a/gcc/ada/libgnat/a-cbhama.adb +++ b/gcc/ada/libgnat/a-cbhama.adb @@ -368,7 +368,7 @@ is -- Empty -- ----------- - function Empty (Capacity : Count_Type) return Map is + function Empty (Capacity : Count_Type := 10) return Map is begin return Result : Map (Capacity, 0) do null; diff --git a/gcc/ada/libgnat/a-cbhama.ads b/gcc/ada/libgnat/a-cbhama.ads index 6ffc815..c741b40 100644 --- a/gcc/ada/libgnat/a-cbhama.ads +++ b/gcc/ada/libgnat/a-cbhama.ads @@ -71,7 +71,7 @@ is -- Map objects declared without an initialization expression are -- initialized to the value Empty_Map. - function Empty (Capacity : Count_Type) return Map; + function Empty (Capacity : Count_Type := 10) return Map; No_Element : constant Cursor; -- Cursor objects declared without an initialization expression are diff --git a/gcc/ada/libgnat/g-calend.adb b/gcc/ada/libgnat/g-calend.adb index e410c3e..a2bc77c 100644 --- a/gcc/ada/libgnat/g-calend.adb +++ b/gcc/ada/libgnat/g-calend.adb @@ -344,6 +344,8 @@ package body GNAT.Calendar is sec : aliased C.Extensions.long_long; usec : aliased C.long; + pragma Unsuppress (Overflow_Check); + begin timeval_to_duration (T, sec'Access, usec'Access); pragma Annotate (CodePeer, Modified, sec); @@ -369,13 +371,28 @@ package body GNAT.Calendar is sec : C.Extensions.long_long; usec : C.long; + pragma Unsuppress (Overflow_Check); + begin if D = 0.0 then sec := 0; usec := 0; + + elsif D < 0.0 then + sec := C.Extensions.long_long (D + 0.5); + if D = Duration (sec) then + usec := 0; + else + usec := C.long ((D - Duration (sec)) * Micro + 0.5); + end if; + else - sec := C.Extensions.long_long (D - 0.5); - usec := C.long ((D - Duration (sec)) * Micro - 0.5); + sec := C.Extensions.long_long (D - 0.5); + if D = Duration (sec) then + usec := 0; + else + usec := C.long ((D - Duration (sec)) * Micro - 0.5); + end if; end if; duration_to_timeval (sec, usec, Result'Access); diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb index 5042dac..0fed791 100644 --- a/gcc/ada/libgnat/g-socket.adb +++ b/gcc/ada/libgnat/g-socket.adb @@ -3059,12 +3059,11 @@ package body GNAT.Sockets is -- Normal case where we do round down else - S := time_t (Val - 0.5); - uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)) - 0.5); - - if uS = -1 then - -- It happen on integer duration + S := time_t (Val - 0.5); + if Val = Timeval_Duration (S) then uS := 0; + else + uS := suseconds_t ((Val - Timeval_Duration (S)) * 1_000_000 - 0.5); end if; end if; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 97537ef..7a5e987 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -1976,7 +1976,7 @@ CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock") #if defined(__linux__) || defined(__FreeBSD__) \ || (defined(_AIX) && defined(_AIXVERSION_530)) \ || defined(__DragonFly__) || defined(__QNX__) \ - || defined (__vxworks) + || (defined (__vxworks) && /* VxWorks7 */ defined (_VSB_CONFIG_FILE)) /** On these platforms use system provided monotonic clock instead of ** the default CLOCK_REALTIME. We then need to set up cond var attributes ** appropriately (see thread.c). @@ -1985,6 +1985,10 @@ CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock") ** pthread_cond_timedwait (and does not have pthread_condattr_setclock), ** hence the conditionalization on AIX version above). _AIXVERSION_530 ** is defined in AIX 5.3 and more recent versions. + ** + ** VxWorks6 lacks pthread_condattr_setclock, so define CLOCK_RT_Ada to + ** CLOCK_REALTIME to get the dummy definition of __gnat_pthread_condattr_setup + ** in libgnarl/thread.c. **/ # define CLOCK_RT_Ada "CLOCK_MONOTONIC" diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 9602944..f38380c 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -9359,6 +9359,20 @@ package body Sem_Attr is when Attribute_First => Set_Bounds; + -- In GNATprove mode we only fold array attributes when prefix is + -- static (because that's required by the Ada rules) or at least can + -- be evaluated without checks (because GNATprove would miss them). + + if GNATprove_Mode + and then + not (Static + or else (Is_Entity_Name (P) and then Is_Type (Entity (P))) + or else Statically_Names_Object (P) + or else Ekind (P_Type) = E_String_Literal_Subtype) + then + return; + end if; + if Compile_Time_Known_Value (Lo_Bound) then if Is_Real_Type (P_Type) then Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static); @@ -9572,6 +9586,20 @@ package body Sem_Attr is when Attribute_Last => Set_Bounds; + -- In GNATprove mode we only fold array attributes when prefix is + -- static (because that's required by the Ada rules) or at least can + -- be evaluated without checks (because GNATprove would miss them). + + if GNATprove_Mode + and then + not (Static + or else (Is_Entity_Name (P) and then Is_Type (Entity (P))) + or else Statically_Names_Object (P) + or else Ekind (P_Type) = E_String_Literal_Subtype) + then + return; + end if; + if Compile_Time_Known_Value (Hi_Bound) then if Is_Real_Type (P_Type) then Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static); @@ -9655,6 +9683,20 @@ package body Sem_Attr is Set_Bounds; + -- In GNATprove mode we only fold array attributes when prefix is + -- static (because that's required by the Ada rules) or at least can + -- be evaluated without checks (because GNATprove would miss them). + + if GNATprove_Mode + and then + not (Static + or else (Is_Entity_Name (P) and then Is_Type (Entity (P))) + or else Statically_Names_Object (P) + or else Ekind (P_Type) = E_String_Literal_Subtype) + then + return; + end if; + -- For two compile time values, we can compute length if Compile_Time_Known_Value (Lo_Bound) diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index bb1624d..0aa74e3 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -25,7 +25,6 @@ with Atree; use Atree; with Einfo; use Einfo; -with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Nlists; use Nlists; with Sinfo; use Sinfo; @@ -454,16 +453,28 @@ package body Sem_Aux is Id : Entity_Id; begin + -- Call using access to subprogram with explicit dereference + if Nkind (Nam) = N_Explicit_Dereference then Id := Etype (Nam); pragma Assert (Ekind (Id) = E_Subprogram_Type); + -- Case of call to simple entry, where the Name is a selected component + -- whose prefix is the task or protected record, and whose selector name + -- is the entry name. + elsif Nkind (Nam) = N_Selected_Component then Id := Entity (Selector_Name (Nam)); + -- Case of call to member of entry family, where Name is an indexed + -- component, with the prefix being a selected component giving the + -- task and entry family name, and the index being the entry index. + elsif Nkind (Nam) = N_Indexed_Component then Id := Entity (Selector_Name (Prefix (Nam))); + -- Normal case + else Id := Entity (Nam); end if; @@ -1546,6 +1557,81 @@ package body Sem_Aux is return E; end Ultimate_Alias; + --------------------------- + -- Unique_Component_Name -- + --------------------------- + + function Unique_Component_Name + (Component : Record_Field_Kind_Id) return Name_Id + is + Homographic_Component_Count : Pos := 1; + Hcc : Pos renames Homographic_Component_Count; + Enclosing_Type : Entity_Id := + Underlying_Type (Base_Type (Scope (Component))); + begin + if Ekind (Enclosing_Type) = E_Record_Type + and then Is_Tagged_Type (Enclosing_Type) + and then Has_Private_Ancestor (Enclosing_Type) + then + -- traverse ancestors to determine Hcc value + loop + declare + Type_Decl : constant Node_Id := + Parent (Underlying_Type (Base_Type (Enclosing_Type))); + Type_Def : constant Node_Id := Type_Definition (Type_Decl); + begin + exit when Nkind (Type_Def) /= N_Derived_Type_Definition; + Enclosing_Type := + Underlying_Type (Base_Type (Etype (Enclosing_Type))); + + declare + Ancestor_Comp : Opt_Record_Field_Kind_Id := + First_Component_Or_Discriminant (Enclosing_Type); + begin + while Present (Ancestor_Comp) loop + if Chars (Ancestor_Comp) = Chars (Component) then + Hcc := Hcc + 1; + exit; -- exit not required, but might as well + end if; + Next_Component_Or_Discriminant (Ancestor_Comp); + end loop; + end; + end; + end loop; + end if; + + if Hcc = 1 then + -- the usual case + return Chars (Component); + else + declare + Buff : Bounded_String; + begin + Append (Buff, Chars (Component)); + + Append (Buff, "__"); + -- A double underscore in an identifier is legal in C, not in Ada. + -- Returning a result that is not a legal Ada identifier + -- ensures that we won't have problems with collisions. + -- If we have a component named Foo and we just append a + -- number (without any underscores), that new name might match + -- the name of another component (which would be bad). + -- The result of this function is intended for use as an + -- identifier in generated C code, so it needs to be a + -- legal C identifer. + + Append (Buff, Hcc); + -- Should we instead append Hcc - 1 here? This is a human + -- readability question. If parent type and extension each + -- have a Foo component, do we want the name returned for the + -- second Foo to be "foo__2" or "foo__1" ? Does it matter? + -- Either way, the name returned for the first Foo will be "foo". + + return Name_Find (Buff); + end; + end if; + end Unique_Component_Name; + -------------------------- -- Unit_Declaration_Node -- -------------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index aad5d32..1a298a9 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -31,6 +31,7 @@ -- require more than minimal semantic knowledge. with Alloc; +with Einfo.Entities; use Einfo.Entities; with Namet; use Namet; with Table; with Types; use Types; @@ -405,6 +406,19 @@ package Sem_Aux is -- Return the last entity in the chain of aliased entities of Prim. If Prim -- has no alias return Prim. + function Unique_Component_Name + (Component : Record_Field_Kind_Id) return Name_Id; + -- Usually, a record type cannot have two components with the same name. + -- But in the case of a component declared in an extension of a tagged + -- private (or private extension) parent type, it is possible that some + -- ancestor type also has a (non-visible) component with the same name. + -- In the common case, this function simply returns the Chars attribute + -- of its argument. + -- But in the multiple-components-with-the-same-name case, it appends + -- a uniquifying suffix. The result in this case will not be a + -- syntactically valid Ada identifier, but it will be a syntactically + -- valid C identifier. + function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; -- Unit_Id is the simple name of a program unit, this function returns the -- corresponding xxx_Declaration node for the entity. Also applies to the diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index e80aea5..b5c9e88 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -7574,6 +7574,12 @@ package body Sem_Ch12 is or else not Same_Instantiated_Function (E1, E2)); end if; + -- No check is needed if this is the body of a subprogram that is + -- implicitly created in the case of class-wide predefined functions. + + elsif Ekind (E1) = E_Subprogram_Body then + null; + else raise Program_Error; end if; @@ -14371,8 +14377,21 @@ package body Sem_Ch12 is elsif Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T) then - Ancestor := - Get_Instance_Of (Base_Type (Etype (A_Gen_T))); + declare + Formal_Ancestor : constant Entity_Id := + Base_Type (Etype (A_Gen_T)); + begin + Ancestor := Get_Instance_Of (Formal_Ancestor); + + -- Handle (rare) case where Get_Instance_Of found nothing in + -- the map. + + if Ancestor = Formal_Ancestor then + Ancestor := + Get_Instance_Of + (Base_Type (Etype (Get_Instance_Of (A_Gen_T)))); + end if; + end; -- The type may be a local derivation, or a type extension of a -- previous formal, or of a formal of a parent package. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 99acbf8..b7ada50 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -337,6 +337,13 @@ package body Sem_Ch13 is -- Resolve each one of the arguments specified in the specification of -- aspect Finalizable. + function Resolve_Finalization_Procedure + (N : Node_Id; + Typ : Entity_Id) return Boolean; + -- Resolve a procedure argument specified in the specification of one of + -- the finalization aspects, i.e. Finalizable and Destructor. Returns True + -- if successful, False otherwise. + procedure Resolve_Iterable_Operation (N : Node_Id; Cursor : Entity_Id; @@ -4647,6 +4654,20 @@ package body Sem_Ch13 is goto Continue; end if; + when Aspect_Destructor => + if not All_Extensions_Allowed then + Error_Msg_Name_1 := Nam; + Error_Msg_GNAT_Extension ("aspect %", Loc); + goto Continue; + + elsif not Is_Type (E) then + Error_Msg_N ("can only be specified for a type", Aspect); + goto Continue; + end if; + + Set_Has_Destructor (E); + Set_Is_Controlled_Active (E); + when Aspect_Storage_Model_Type => if not All_Extensions_Allowed then Error_Msg_Name_1 := Nam; @@ -5064,6 +5085,14 @@ package body Sem_Ch13 is Check_Expr_Is_OK_Static_Expression (Expr, Any_Boolean); end if; + -- Record the No_Task_Parts aspects as a rep item so it + -- can be consistently looked up on the full view of the + -- type. + + if Is_Private_Type (E) then + Record_Rep_Item (E, Aspect); + end if; + goto Continue; -- Ada 2022 (AI12-0075): static expression functions @@ -11241,6 +11270,13 @@ package body Sem_Ch13 is -- Start of processing for Check_Aspect_At_End_Of_Declarations begin + -- Indicate that the expression comes from an aspect specification, + -- which is used in subsequent analysis even if expansion is off. + + if Present (End_Decl_Expr) then + Set_Parent (End_Decl_Expr, ASN); + end if; + -- In an instance we do not perform the consistency check between freeze -- point and end of declarations, because it was done already in the -- analysis of the generic. Furthermore, the delayed analysis of an @@ -11270,6 +11306,7 @@ package body Sem_Ch13 is -- the one available at at the freeze point. elsif A_Id in Aspect_Constructor + | Aspect_Destructor | Aspect_Input | Aspect_Output | Aspect_Read @@ -11332,13 +11369,6 @@ package body Sem_Ch13 is end if; end if; - -- Indicate that the expression comes from an aspect specification, - -- which is used in subsequent analysis even if expansion is off. - - if Present (End_Decl_Expr) then - Set_Parent (End_Decl_Expr, ASN); - end if; - -- In a generic context the original aspect expressions have not -- been preanalyzed, so do it now. There are no conformance checks -- to perform in this case. As before, we have to make components @@ -11734,6 +11764,67 @@ package body Sem_Ch13 is Analyze (Expression (ASN)); return; + when Aspect_Destructor => + if not Is_Record_Type (Entity (ASN)) then + Error_Msg_N + ("aspect Destructor can only be specified for a " + & "record type", + ASN); + return; + end if; + + Set_Has_Destructor (Entity (ASN)); + Set_Is_Controlled_Active (Entity (ASN)); + + Analyze (Expression (ASN)); + + if not Resolve_Finalization_Procedure + (Expression (ASN), Entity (ASN)) + then + Error_Msg_N + ("destructor must be local procedure whose only formal " + & "parameter has mode `IN OUT` and is of the type the " + & "destructor is for", + Expression (ASN)); + end if; + + Set_Is_Destructor (Entity (Expression (ASN))); + + declare + Proc : constant Entity_Id := Entity (Expression (ASN)); + Overr : constant Opt_N_Entity_Id := + Overridden_Inherited_Operation (Proc); + Orig : constant Entity_Id := + (if Present (Overr) then Overr else Proc); + + Decl : constant Node_Id := + Parent + (if Nkind (Parent (Orig)) = N_Procedure_Specification + then Parent (Orig) + else Orig); + + Encl : constant Node_Id := Parent (Decl); + + Is_Private : constant Boolean := + Nkind (Encl) = N_Package_Specification + and then Is_List_Member (Decl) + and then List_Containing (Decl) = Private_Declarations (Encl); + + begin + + if Has_Private_Declaration (Entity (ASN)) + and then not Aspect_On_Partial_View (ASN) + and then not Is_Private + then + Error_Msg_N + ("aspect Destructor on full view cannot denote public " + & "primitive", + ASN); + end if; + end; + + return; + when Aspect_Storage_Model_Type => -- The aggregate argument of Storage_Model_Type is optional, and @@ -15887,6 +15978,8 @@ package body Sem_Ch13 is -- We may freeze Subp_Id immediately since Ent has just been frozen. -- This will help to shield us from potential late freezing issues. + Mutate_Ekind (Subp_Id, E_Procedure); + Freeze_Extra_Formals (Subp_Id); Set_Is_Frozen (Subp_Id); else @@ -17334,6 +17427,35 @@ package body Sem_Ch13 is Typ : Entity_Id; Nam : Name_Id) is + begin + if Nam = Name_Relaxed_Finalization then + Resolve (N, Any_Boolean); + + if Is_OK_Static_Expression (N) then + Set_Has_Relaxed_Finalization (Typ, Is_True (Static_Boolean (N))); + + else + Flag_Non_Static_Expr + ("expression of aspect Finalizable must be static!", N); + end if; + + return; + end if; + + if Resolve_Finalization_Procedure (N, Typ) then + return; + end if; + + Error_Msg_N + ("finalizable primitive must be local procedure whose only formal " & + "parameter has mode `IN OUT` and is of the finalizable type", N); + end Resolve_Finalizable_Argument; + + function Resolve_Finalization_Procedure + (N : Node_Id; + Typ : Entity_Id) + return Boolean + is function Is_Finalizable_Primitive (E : Entity_Id) return Boolean; -- Check whether E is a finalizable primitive for Typ @@ -17351,29 +17473,15 @@ package body Sem_Ch13 is and then No (Next_Formal (First_Formal (E))); end Is_Finalizable_Primitive; - -- Start of processing for Resolve_Finalizable_Argument + -- Start of processing for Resolve_Finalization_Procedure begin - if Nam = Name_Relaxed_Finalization then - Resolve (N, Any_Boolean); - - if Is_OK_Static_Expression (N) then - Set_Has_Relaxed_Finalization (Typ, Is_True (Static_Boolean (N))); - - else - Flag_Non_Static_Expr - ("expression of aspect Finalizable must be static!", N); - end if; - - return; - end if; - if not Is_Entity_Name (N) then null; elsif not Is_Overloaded (N) then if Is_Finalizable_Primitive (Entity (N)) then - return; + return True; end if; else @@ -17389,7 +17497,7 @@ package body Sem_Ch13 is while Present (It.Typ) loop if Is_Finalizable_Primitive (It.Nam) then Set_Entity (N, It.Nam); - return; + return True; end if; Get_Next_Interp (I, It); @@ -17397,10 +17505,8 @@ package body Sem_Ch13 is end; end if; - Error_Msg_N - ("finalizable primitive must be local procedure whose only formal " & - "parameter has mode `IN OUT` and is of the finalizable type", N); - end Resolve_Finalizable_Argument; + return False; + end Resolve_Finalization_Procedure; -------------------------------- -- Resolve_Iterable_Operation -- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 5354d82..3726169 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3020,6 +3020,8 @@ package body Sem_Ch3 is ----------------------------------- procedure Analyze_Full_Type_Declaration (N : Node_Id) is + use Deferred_Extra_Formals_Support; + Def : constant Node_Id := Type_Definition (N); Def_Id : constant Entity_Id := Defining_Identifier (N); T : Entity_Id; @@ -3558,6 +3560,16 @@ package body Sem_Ch3 is end if; end if; + -- If we have some subprogram, subprogram type, or entry, with deferred + -- addition of its extra formals (because the underlying type of this + -- type was not previously available), then try creating now its extra + -- formals. Create also the extra actuals of deferred calls to entities + -- with deferred extra formals. + + if Has_Deferred_Extra_Formals (T) then + Add_Deferred_Extra_Params (T); + end if; + if Ekind (T) = E_Record_Type and then Is_Large_Unconstrained_Definite (T) and then not Is_Limited_Type (T) @@ -6819,7 +6831,7 @@ package body Sem_Ch3 is -- that the element type is constrained. if Is_Mutably_Tagged_Type (Element_Type) then - Set_Component_Type (T, + Set_Component_Type (Base_Type (T), Class_Wide_Equivalent_Type (Element_Type)); elsif not Is_Definite_Subtype (Element_Type) then @@ -8440,15 +8452,17 @@ package body Sem_Ch3 is Set_Has_Private_Declaration (Full_Der); Set_Has_Private_Declaration (Derived_Type); - Set_Scope (Full_Der, Scope (Derived_Type)); - Set_Is_First_Subtype (Full_Der, Is_First_Subtype (Derived_Type)); - Set_Has_Size_Clause (Full_Der, False); - Set_Has_Alignment_Clause (Full_Der, False); - Set_Has_Delayed_Freeze (Full_Der); - Set_Is_Frozen (Full_Der, False); - Set_Freeze_Node (Full_Der, Empty); - Set_Depends_On_Private (Full_Der, Has_Private_Component (Full_Der)); - Set_Is_Public (Full_Der, Is_Public (Derived_Type)); + Set_Scope (Full_Der, Scope (Derived_Type)); + Set_Is_First_Subtype (Full_Der, Is_First_Subtype (Derived_Type)); + Set_Has_Size_Clause (Full_Der, False); + Set_Has_Alignment_Clause (Full_Der, False); + Set_Has_Delayed_Freeze (Full_Der); + Set_Is_Frozen (Full_Der, False); + Set_Freeze_Node (Full_Der, Empty); + Set_Depends_On_Private + (Full_Der, Has_Private_Component (Full_Der)); + Set_Is_Public (Full_Der, Is_Public (Derived_Type)); + Set_Is_Implicit_Full_View (Full_Der); -- The convention on the base type may be set in the private part -- and not propagated to the subtype until later, so we obtain the @@ -9646,6 +9660,8 @@ package body Sem_Ch3 is (New_Decl, Parent_Base, New_Base, Is_Completion => False, Derive_Subps => False); + Set_Is_Implicit_Full_View (New_Base); + -- ??? This needs re-examination to determine whether the -- following call can simply be replaced by a call to Analyze. @@ -21279,8 +21295,8 @@ package body Sem_Ch3 is -- On entry, the current scope is the composite type. -- The discriminants are initially entered into the scope of the type - -- via Enter_Name with the default Ekind of E_Void to prevent premature - -- use, as explained at the end of this procedure. + -- via Enter_Name with Is_Not_Self_Hidden set to False to prevent + -- premature use, as explained at the end of this procedure. Discr := First (Discriminant_Specifications (N)); while Present (Discr) loop @@ -21553,12 +21569,12 @@ package body Sem_Ch3 is -- expressions of a discriminant part if the specification of the -- discriminant is itself given in the discriminant part. (RM 3.7.1) - -- To detect this, the discriminant names are entered initially with an - -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any - -- attempt to use a void entity (for example in an expression that is - -- type-checked) produces the error message: premature usage. Now after - -- completing the semantic analysis of the discriminant part, we can set - -- the Ekind of all the discriminants appropriately. + -- To detect this, the discriminant names are entered initially with + -- Is_Not_Self_Hidden set to False. Any attempt to use a self-hidden + -- entity (for example in an expression that is type-checked) produces + -- the error message: premature usage. Now after completing the semantic + -- analysis of the discriminant part, we can set Is_Not_Self_Hidden on + -- all the discriminants appropriately. Discr := First (Discriminant_Specifications (N)); Discr_Number := Uint_1; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 56dc7c6..018c8a0 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -5603,6 +5603,10 @@ package body Sem_Ch4 is if No (Act_Decl) then Set_Etype (N, Etype (Comp)); + if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (N)) then + Make_Mutably_Tagged_Conversion (N); + end if; + else -- If discriminants were present in the component -- declaration, they have been replaced by the @@ -10406,11 +10410,14 @@ package body Sem_Ch4 is -- may be candidates, so that Try_Primitive_Operations can examine -- them if no real primitive is found. - function Is_Private_Overriding (Op : Entity_Id) return Boolean; + function Is_Callable_Private_Overriding + (Op : Entity_Id) return Boolean; -- An operation that overrides an inherited operation in the private -- part of its package may be hidden, but if the inherited operation - -- is visible a direct call to it will dispatch to the private one, - -- which is therefore a valid candidate. + -- that it overrides is visible, then a direct call to it will + -- dispatch to the private one, which is therefore a valid candidate. + -- Returns True if the operation can be called from outside the + -- enclosing package. function Names_Match (Obj_Type : Entity_Id; @@ -10581,11 +10588,13 @@ package body Sem_Ch4 is return Op_List; end Extended_Primitive_Ops; - --------------------------- - -- Is_Private_Overriding -- - --------------------------- + ------------------------------------ + -- Is_Callable_Private_Overriding -- + ------------------------------------ - function Is_Private_Overriding (Op : Entity_Id) return Boolean is + function Is_Callable_Private_Overriding + (Op : Entity_Id) return Boolean + is Visible_Op : Entity_Id; begin @@ -10607,7 +10616,10 @@ package body Sem_Ch4 is -- have found what we're looking for. if not Is_Hidden (Visible_Op) - or else not Is_Hidden (Overridden_Operation (Op)) + or else + (Present (Overridden_Inherited_Operation (Op)) + and then not Is_Hidden + (Overridden_Inherited_Operation (Op))) then return True; end if; @@ -10617,7 +10629,7 @@ package body Sem_Ch4 is end loop; return False; - end Is_Private_Overriding; + end Is_Callable_Private_Overriding; ----------------- -- Names_Match -- @@ -10760,13 +10772,15 @@ package body Sem_Ch4 is -- Do not consider hidden primitives unless the type is in an -- open scope or we are within an instance, where visibility - -- is known to be correct, or else if this is an overriding - -- operation in the private part for an inherited operation. + -- is known to be correct, or else if this is an operation + -- declared in the private part that overrides a visible + -- inherited operation. or else (Is_Hidden (Prim_Op) and then not Is_Immediately_Visible (Obj_Type) and then not In_Instance - and then not Is_Private_Overriding (Prim_Op)) + and then + not Is_Callable_Private_Overriding (Prim_Op)) then goto Continue; end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index e1d6be4..0661e64 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -807,7 +807,14 @@ package body Sem_Ch5 is if Is_Tag_Indeterminate (Rhs) then if Is_Class_Wide_Type (T1) then - Propagate_Tag (Lhs, Rhs); + + -- No need to propagate the tag when the RHS has function calls + -- that already propagated it (see Expand_Call_Helper), or if + -- some error was reported analyzing RHS. + + if not (Error_Posted (Rhs) or else Tag_Propagated (Lhs)) then + Propagate_Tag (Lhs, Rhs); + end if; elsif Nkind (Rhs) = N_Function_Call and then Is_Entity_Name (Name (Rhs)) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 48dcf8e..709f625 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3864,9 +3864,14 @@ package body Sem_Ch6 is Spec_Id := Build_Internal_Protected_Declaration (N); end if; - -- If a separate spec is present, then deal with freezing issues + -- Separate spec is not present - if Present (Spec_Id) then + if No (Spec_Id) then + Create_Extra_Formals (Body_Id); + + -- Separate spec is present; deal with freezing issues + + else Spec_Decl := Unit_Declaration_Node (Spec_Id); Verify_Overriding_Indicator; @@ -3882,6 +3887,8 @@ package body Sem_Ch6 is and then not Has_BIP_Formals (Spec_Id) then Create_Extra_Formals (Spec_Id); + pragma Assert (not Expander_Active + or else Extra_Formals_Known (Spec_Id)); Compute_Returns_By_Ref (Spec_Id); end if; @@ -8564,14 +8571,13 @@ package body Sem_Ch6 is -- without coordinating with CodePeer, which makes use of these to -- provide better messages. + -- A and B denote extra formals for unchecked unions equality. See + -- exp_ch3.Build_Variant_Record_Equality. -- O denotes the Constrained bit. -- L denotes the accessibility level. -- BIP_xxx denotes an extra formal for a build-in-place function. See -- the full list in exp_ch6.BIP_Formal_Kind. - function Has_Extra_Formals (E : Entity_Id) return Boolean; - -- Determines if E has its extra formals - function Might_Need_BIP_Task_Actuals (E : Entity_Id) return Boolean; -- Determines if E is a function or an access to a function returning a -- limited tagged type object. On dispatching primitives this predicate @@ -8610,14 +8616,6 @@ package body Sem_Ch6 is EF : Entity_Id; begin - -- A little optimization. Never generate an extra formal for the - -- _init operand of an initialization procedure, since it could - -- never be used. - - if Chars (Formal) = Name_uInit then - return Empty; - end if; - EF := Make_Defining_Identifier (Sloc (Assoc_Entity), Chars => New_External_Name (Chars (Assoc_Entity), Suffix => Suffix)); @@ -8643,25 +8641,22 @@ package body Sem_Ch6 is return EF; end Add_Extra_Formal; - ----------------------- - -- Has_Extra_Formals -- - ----------------------- - - function Has_Extra_Formals (E : Entity_Id) return Boolean is - begin - return Present (Extra_Formals (E)) - or else - (Ekind (E) = E_Function - and then Present (Extra_Accessibility_Of_Result (E))); - end Has_Extra_Formals; - --------------------------------- -- Might_Need_BIP_Task_Actuals -- --------------------------------- function Might_Need_BIP_Task_Actuals (E : Entity_Id) return Boolean is Subp_Id : Entity_Id; - Func_Typ : Entity_Id; + Original : Entity_Id; + Root : Entity_Id; + + function Has_No_Task_Parts_Enabled (E : Entity_Id) return Boolean + is (Has_Enabled_Aspect (E, Aspect_No_Task_Parts)); + + function Collect_Ancestors_With_No_Task_Parts is new + Collect_Types_In_Hierarchy (Predicate => Has_No_Task_Parts_Enabled); + + -- Start of processing for Might_Need_BIP_Task_Actuals begin if Global_No_Tasking or else No_Run_Time_Mode then @@ -8689,21 +8684,29 @@ package body Sem_Ch6 is then Subp_Id := Protected_Body_Subprogram (E); - else + -- For access-to-subprogram types we look at the return type of the + -- subprogram type itself, as it cannot be overridden or inherited. + + elsif Ekind (E) = E_Subprogram_Type then Subp_Id := E; - end if; - -- We check the root type of the return type since the same - -- decision must be taken for all descendants overriding a - -- dispatching operation. + -- Otherwise, we need to return the same value we would return for + -- the original corresponding operation of the root of the aliased + -- chain. + + else + Subp_Id := Original_Corresponding_Operation (Ultimate_Alias (E)); + end if; - Func_Typ := Root_Type (Underlying_Type (Etype (Subp_Id))); + Original := Underlying_Type (Etype (Subp_Id)); + Root := Underlying_Type (Root_Type (Original)); return Ekind (Subp_Id) in E_Function | E_Subprogram_Type - and then not Has_Foreign_Convention (Func_Typ) - and then Is_Tagged_Type (Func_Typ) - and then Is_Limited_Type (Func_Typ) - and then not Has_Aspect (Func_Typ, Aspect_No_Task_Parts); + and then Is_Inherently_Limited_Type (Original) + and then not Has_Foreign_Convention (Root) + and then Is_Tagged_Type (Root) + and then Is_Empty_Elmt_List + (Collect_Ancestors_With_No_Task_Parts (Original)); end Might_Need_BIP_Task_Actuals; ------------------------------------- @@ -8792,10 +8795,12 @@ package body Sem_Ch6 is -- we have no direct way to climb to the corresponding parent -- subprogram but this internal entity has the extra formals -- (if any) required for the purpose of checking the extra - -- formals of Subp_Id. + -- formals of Subp_Id because its extra formals are shared + -- with its parent subprogram (see Sem_Ch3.Derive_Subprogram). else pragma Assert (not Comes_From_Source (Ovr_E)); + Freeze_Extra_Formals (Ovr_E); end if; -- Use as our reference entity the ultimate renaming of the @@ -8818,10 +8823,14 @@ package body Sem_Ch6 is -- Local variables - Formal_Type : Entity_Id; - May_Have_Alias : Boolean; + use Deferred_Extra_Formals_Support; + + Can_Be_Deferred : constant Boolean := + not Is_Unsupported_Extra_Formals_Entity (E); Alias_Formal : Entity_Id := Empty; Alias_Subp : Entity_Id := Empty; + Formal_Type : Entity_Id; + May_Have_Alias : Boolean; Parent_Formal : Entity_Id := Empty; Parent_Subp : Entity_Id := Empty; Ref_E : Entity_Id; @@ -8832,10 +8841,18 @@ package body Sem_Ch6 is pragma Assert (Is_Subprogram_Or_Entry (E) or else Ekind (E) in E_Subprogram_Type); + -- No action needed if extra formals were already handled. This + -- situation may arise because of a previous call to create the + -- extra formals, and also for subprogram types created as part + -- of dispatching calls (see Expand_Dispatching_Call). + + if Extra_Formals_Known (E) then + return; + -- We never generate extra formals if expansion is not active because we -- don't need them unless we are generating code. - if not Expander_Active then + elsif not Expander_Active then return; -- Enumeration literals have no extra formal; this case occurs when @@ -8844,25 +8861,38 @@ package body Sem_Ch6 is elsif Ekind (E) = E_Function and then Ekind (Ultimate_Alias (E)) = E_Enumeration_Literal then + Freeze_Extra_Formals (E); return; - -- Extra formals of Initialization procedures are added by the function - -- Exp_Ch3.Init_Formals + -- Extra formals of init procs are added by Exp_Ch3.Init_Formals and + -- Set_CPP_Constructors when they are built, but we must handle here + -- aliased init procs. elsif Is_Init_Proc (E) then + pragma Assert (Present (Alias (E))); + pragma Assert (Extra_Formals_Known (Ultimate_Alias (E))); + Freeze_Extra_Formals (E); return; -- No need to generate extra formals in thunks whose target has no extra -- formals, but we can have two of them chained (interface and stack). - elsif Is_Thunk (E) and then No (Extra_Formals (Thunk_Target (E))) then + elsif Is_Thunk (E) + and then Extra_Formals_Known (Thunk_Target (E)) + and then No (Extra_Formals (Thunk_Target (E))) + then + Freeze_Extra_Formals (E); return; - -- If Extra_Formals were already created, don't do it again. This - -- situation may arise for subprogram types created as part of - -- dispatching calls (see Expand_Dispatching_Call). + -- Handle alias of unchecked union equality with frozen extra formals - elsif Has_Extra_Formals (E) then + elsif Is_Overloadable (E) + and then Present (Alias (E)) + and then Extra_Formals_Known (Ultimate_Alias (E)) + and then Is_Unchecked_Union_Equality (Ultimate_Alias (E)) + then + Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E))); + Freeze_Extra_Formals (E); return; -- Extra formals of renamings of generic actual subprograms and @@ -8880,6 +8910,8 @@ package body Sem_Ch6 is = Is_Generic_Instance (Ultimate_Alias (E))); Create_Extra_Formals (Ultimate_Alias (E)); + pragma Assert (not Expander_Active + or else Extra_Formals_Known (Ultimate_Alias (E))); -- Share the extra formals @@ -8891,17 +8923,72 @@ package body Sem_Ch6 is end if; pragma Assert (Extra_Formals_OK (E)); + Freeze_Extra_Formals (E); return; end if; - -- Locate the last formal; required by Add_Extra_Formal. + -- Check if the addition of the extra formals must be deferred Formal := First_Formal (E); while Present (Formal) loop - Last_Extra := Formal; + if No (Underlying_Type (Etype (Formal))) + and then Can_Be_Deferred + then + Register_Deferred_Extra_Formals_Entity (E); + return; + end if; + Next_Formal (Formal); end loop; + if Ekind (E) in E_Function + | E_Subprogram_Type + and then No (Underlying_Type (Etype (E))) + and then Can_Be_Deferred + then + Register_Deferred_Extra_Formals_Entity (E); + return; + end if; + + -- Here we start adding the extra formals + + -- We we know that either the underlying type of all the formals and + -- returned results of E are known, or this is an special case where + -- some underlying type is still not available. + + -- In the former case, we can already mark functions that return their + -- result by reference; in the latter case, we can mark them only if the + -- underlying return type is available (and it will be marked later). + + if not Is_Unsupported_Extra_Formals_Entity (E) + or else (Ekind (E) in E_Function | E_Subprogram_Type + and then Present (Underlying_Type (Etype (E)))) + then + Compute_Returns_By_Ref (E); + end if; + + -- Locate the last formal (required by Add_Extra_Formal) + + if Present (First_Formal (E)) + and then Is_Unchecked_Union (Etype (First_Formal (E))) + and then Present (Extra_Formals (E)) + and then Has_Suffix (Extra_Formals (E), 'A') + then + -- An unchecked union equality has two extra formals per discriminant + + First_Extra := Extra_Formals (E); + Last_Extra := First_Extra; + while Present (Last_Extra) loop + pragma Assert (Has_Suffix (Last_Extra, 'A')); + Last_Extra := Extra_Formal (Last_Extra); + + pragma Assert (Has_Suffix (Last_Extra, 'B')); + Last_Extra := Extra_Formal (Last_Extra); + end loop; + else + Last_Extra := Last_Formal (E); + end if; + -- We rely on three entities to ensure consistency of extra formals of -- entity E: -- @@ -8961,6 +9048,7 @@ package body Sem_Ch6 is or else (Present (Alias_Subp) and then Has_Foreign_Convention (Alias_Subp)) then + Freeze_Extra_Formals (E); return; end if; @@ -9039,14 +9127,44 @@ package body Sem_Ch6 is -- Here we establish our priority for deciding on the extra -- formals: 1) Parent primitive 2) Aliased primitive 3) Identity - if Present (Parent_Formal) then - Formal_Type := Etype (Parent_Formal); + -- Common case: the underlying type of all the formals is known + -- to be available. + + if Can_Be_Deferred then + if Present (Parent_Formal) then + Formal_Type := Underlying_Type (Etype (Parent_Formal)); + elsif Present (Alias_Formal) then + Formal_Type := Underlying_Type (Etype (Alias_Formal)); + else + Formal_Type := Underlying_Type (Etype (Formal)); + end if; + + pragma Assert (Present (Formal_Type)); - elsif Present (Alias_Formal) then - Formal_Type := Etype (Alias_Formal); + -- Special case: The underlying type of some formal is not available. + -- We use the underlying type when present. More work needed here??? else - Formal_Type := Etype (Formal); + if Present (Parent_Formal) then + Formal_Type := Etype (Parent_Formal); + + if Present (Underlying_Type (Formal_Type)) then + Formal_Type := Underlying_Type (Formal_Type); + end if; + + elsif Present (Alias_Formal) then + Formal_Type := Etype (Alias_Formal); + + if Present (Underlying_Type (Formal_Type)) then + Formal_Type := Underlying_Type (Formal_Type); + end if; + else + Formal_Type := Etype (Formal); + + if Present (Underlying_Type (Formal_Type)) then + Formal_Type := Underlying_Type (Formal_Type); + end if; + end if; end if; -- Create extra formal for supporting the attribute 'Constrained. @@ -9093,12 +9211,13 @@ package body Sem_Ch6 is and then (Is_Definite_Subtype (Formal_Type) or else Is_Mutably_Tagged_Type (Formal_Type)) and then (Ada_Version < Ada_2012 - or else No (Underlying_Type (Formal_Type)) + or else + (not Can_Be_Deferred + and then No (Underlying_Type (Formal_Type))) or else not (Is_Limited_Type (Formal_Type) and then - Is_Tagged_Type - (Underlying_Type (Formal_Type)))) + Is_Tagged_Type (Formal_Type))) then Set_Extra_Constrained (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O")); @@ -9337,6 +9456,8 @@ package body Sem_Ch6 is Set_Extra_Formals (Alias (E), Extra_Formals (E)); end if; + Freeze_Extra_Formals (E); + pragma Assert (No (Alias_Subp) or else Extra_Formals_Match_OK (E, Alias_Subp)); @@ -9651,6 +9772,19 @@ package body Sem_Ch6 is return False; end if; + -- Extra formals (A and B) of Unchecked_Unions (see Build_Variant_ + -- Record_Equality) + + elsif Has_Suffix (Formal_1, 'A') then + if not Has_Suffix (Formal_2, 'A') then + return False; + end if; + + elsif Has_Suffix (Formal_1, 'B') then + if not Has_Suffix (Formal_2, 'B') then + return False; + end if; + elsif BIP_Suffix_Kind (Formal_1) /= BIP_Suffix_Kind (Formal_2) then return False; end if; @@ -10003,6 +10137,16 @@ package body Sem_Ch6 is return Empty; end Find_Corresponding_Spec; + -------------------------- + -- Freeze_Extra_Formals -- + -------------------------- + + procedure Freeze_Extra_Formals (E : Entity_Id) is + begin + pragma Assert (not Extra_Formals_Known (E)); + Set_Extra_Formals_Known (E); + end Freeze_Extra_Formals; + ---------------------- -- Fully_Conformant -- ---------------------- @@ -10622,6 +10766,10 @@ package body Sem_Ch6 is Formal : Entity_Id := First_Formal_With_Extras (E); begin + -- It makes no sense to perform this check if the extra formals + -- have not been added. + pragma Assert (Extra_Formals_Known (E)); + while Present (Formal) loop if Is_Build_In_Place_Entity (Formal) then return True; @@ -12133,36 +12281,51 @@ package body Sem_Ch6 is and then Present (Find_Dispatching_Type (Alias (S))) and then Is_Interface (Find_Dispatching_Type (Alias (S))) then - -- For private types, when the full-view is processed we propagate to - -- the full view the non-overridden entities whose attribute "alias" - -- references an interface primitive. These entities were added by - -- Derive_Subprograms to ensure that interface primitives are - -- covered. - - -- Inside_Freeze_Actions is non zero when S corresponds with an - -- internal entity that links an interface primitive with its - -- covering primitive through attribute Interface_Alias (see - -- Add_Internal_Interface_Entities). - - if Inside_Freezing_Actions = 0 - and then Is_Package_Or_Generic_Package (Current_Scope) - and then In_Private_Part (Current_Scope) - and then Parent_Kind (E) = N_Private_Extension_Declaration - and then Nkind (Parent (S)) = N_Full_Type_Declaration - and then Full_View (Defining_Identifier (Parent (E))) - = Defining_Identifier (Parent (S)) - and then Alias (E) = Alias (S) - then - Check_Operation_From_Private_View (S, E); - Set_Is_Dispatching_Operation (S); + declare + Private_Operation_Exported_By_Visible_Part : constant Boolean := + Is_Package_Or_Generic_Package (Current_Scope) + and then In_Private_Part (Current_Scope) + and then Parent_Kind (E) = N_Private_Extension_Declaration + and then Nkind (Parent (S)) = N_Full_Type_Declaration + and then Full_View (Defining_Identifier (Parent (E))) + = Defining_Identifier (Parent (S)); + + begin + -- For private types, when the full view is processed we propagate + -- to the full view the nonoverridden entities whose attribute + -- "alias" references an interface primitive. These entities were + -- added by Derive_Subprograms to ensure that interface primitives + -- are covered. + + -- Inside_Freeze_Actions is nonzero when S corresponds to an + -- internal entity that links an interface primitive with its + -- covering primitive through attribute Interface_Alias (see + -- Add_Internal_Interface_Entities). + + if Inside_Freezing_Actions = 0 + and then Private_Operation_Exported_By_Visible_Part + and then Alias (E) = Alias (S) + then + Check_Operation_From_Private_View (S, E); + Set_Is_Dispatching_Operation (S); - -- Common case + -- Common case - else - Enter_Overloaded_Entity (S); - Check_Dispatching_Operation (S, Empty); - Check_For_Primitive_Subprogram (Is_Primitive_Subp); - end if; + else + Enter_Overloaded_Entity (S); + Check_Dispatching_Operation (S, Empty); + Check_For_Primitive_Subprogram (Is_Primitive_Subp); + end if; + + if Private_Operation_Exported_By_Visible_Part + and then Type_Conformant (E, S) + then + -- Record the actual inherited subprogram that's being + -- overridden. + + Set_Overridden_Inherited_Operation (S, E); + end if; + end; return; end if; @@ -12601,6 +12764,26 @@ package body Sem_Ch6 is and then not Is_Dispatch_Table_Wrapper (S))) then Set_Overridden_Operation (S, Alias (E)); + + -- Record the actual inherited subprogram that's being + -- overridden. In the case where a subprogram declared + -- in a private part overrides an inherited subprogram + -- that itself is also declared in the private part, + -- and that subprogram in turns overrides a subprogram + -- declared in a package visible part (inherited via + -- a private extension), we record the visible subprogram + -- as the overridden one, so that we can determine + -- visibility properly for prefixed calls to the + -- subprogram made from outside the package. (See + -- Try_Primitive_Operation in Sem_Ch4.) + + if Present (Overridden_Inherited_Operation (E)) then + Set_Overridden_Inherited_Operation + (S, Overridden_Inherited_Operation (E)); + else + Set_Overridden_Inherited_Operation (S, E); + end if; + Inherit_Subprogram_Contract (S, Alias (E)); Set_Is_Ada_2022_Only (S, Is_Ada_2022_Only (Alias (E))); @@ -12760,6 +12943,530 @@ package body Sem_Ch6 is end if; end New_Overloaded_Entity; + ------------------------------------ + -- Deferred_Extra_Formals_Support -- + ------------------------------------ + + package body Deferred_Extra_Formals_Support is + Calls_List : Elist_Id := No_Elist; + Calls_Scope_List : Elist_Id := No_Elist; + -- Calls to subprograms or entries with some unknown underlying type + -- in their parameters or result type, and the scope where each call + -- is performed. + + Entities_List : Elist_Id := No_Elist; + -- Subprograms, entries, and subprogram types with some unknown + -- underlying type in their formals or result type. + + Types_List : Elist_Id := No_Elist; + -- Types with no underlying type + + function Underlying_Types_Available (E : Entity_Id) return Boolean; + -- Determines if the underlying type of all the formals and result + -- type of the given subprogram, subprogram type, or entry are + -- available. + + ------------------------------- + -- Add_Deferred_Extra_Params -- + ------------------------------- + + procedure Add_Deferred_Extra_Params (Typ : Entity_Id) is + + procedure Check_Registered_Calls; + -- Check all the registered calls; for each registered call that + -- has the underlying type of all the parameters and result types + -- of the called entity available, call Create_Extra_Actuals, and + -- unregister the call. + + procedure Check_Registered_Entities; + -- Check all the registered entities (subprograms, entries and + -- subprogram types); for each registered entity E that has all + -- its underlying types available, call Create_Extra_Formals, + -- and unregister E. + + ---------------------------- + -- Check_Registered_Calls -- + ---------------------------- + + procedure Check_Registered_Calls is + + function Get_Relocated_Function_Call (N : Node_Id) return Node_Id; + -- Given a node N that references a function call that has been + -- relocated to remove possible side effects of the call (see + -- Remove_Side_Effects) or to wrap the call in a transient scope + -- (see Wrap_Transient_Expression), search and return the function + -- call. Notice that this function does not use the Original_Node + -- field of N; it searchs for the actual call associated with N + -- in the expanded code (since we need to add to such call its + -- missing extra actuals). + + --------------------------------- + -- Get_Relocated_Function_Call -- + --------------------------------- + + function Get_Relocated_Function_Call (N : Node_Id) return Node_Id + is + Current_Node : Node_Id; + Decl : Node_Id; + Id : Entity_Id; + + begin + Current_Node := N; + + while Nkind (Current_Node) /= N_Function_Call loop + case Nkind (Current_Node) is + when N_Identifier => + Id := Entity (Current_Node); + Decl := Parent (Id); + + if Nkind (Decl) = N_Object_Renaming_Declaration then + Current_Node := Name (Decl); + + else + pragma Assert (Nkind (Decl) = N_Object_Declaration); + + if Present (Expression (Decl)) then + Current_Node := Expression (Decl); + + elsif Present (BIP_Initialization_Call (Id)) then + Decl := BIP_Initialization_Call (Id); + pragma Assert (Present (Expression (Decl))); + Current_Node := Expression (Decl); + + elsif Present (Related_Expression (Id)) then + Current_Node := Related_Expression (Id); + + else + pragma Assert (False); + raise Program_Error; + end if; + end if; + + when N_Explicit_Dereference | N_Reference => + Current_Node := Prefix (Current_Node); + + when others => + pragma Assert (False); + raise Program_Error; + end case; + end loop; + + return Current_Node; + end Get_Relocated_Function_Call; + + -- Local variables + + Call_Node : Node_Id; + Call_Id : Entity_Id; + Elmt_Call : Elmt_Id; + Elmt_Scope : Elmt_Id; + Remove_Call : Boolean; + Scop_Id : Entity_Id; + + -- Start of processing for Check_Registered_Calls + + begin + -- Perform a single traversal of both lists simultaneously, + -- since they have the same number of elements with a 1-to-1 + -- relationship. + + Elmt_Scope := First_Elmt (Calls_Scope_List); + Elmt_Call := First_Elmt (Calls_List); + + while Present (Elmt_Scope) loop + Scop_Id := Node (Elmt_Scope); + Remove_Call := False; + + -- Check the enclosing scope of the call: if the underlying + -- type of some formal or return type of the enclosing scope + -- of this call is not available then we must skip processing + -- this call. + + if Underlying_Types_Available (Scop_Id) then + Call_Node := Node (Elmt_Call); + + if Nkind (Call_Node) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement + then + Call_Id := Get_Called_Entity (Call_Node); + + -- Handle expanded function calls that could have side + -- effects. + + else + pragma Assert + (Nkind (Original_Node (Call_Node)) = N_Function_Call); + + Call_Node := Get_Relocated_Function_Call (Call_Node); + Call_Id := Get_Called_Entity (Call_Node); + end if; + + -- If the underlying types of all the formal and return + -- types of this called entity are available then create + -- its extra actuals and remove it from the list of + -- registered calls. + + if Underlying_Types_Available (Call_Id) then + + -- Given that the call is placed in the body of an + -- internally built subprogram, ensure that the extra + -- formals of the enclosing scope are available before + -- adding the extra actuals of this call. + + Create_Extra_Formals (Scop_Id); + Create_Extra_Formals (Call_Id); + + pragma Assert (Extra_Formals_Known (Scop_Id)); + pragma Assert (Extra_Formals_Known (Call_Id)); + + -- Mark functions that return a result by reference + + Compute_Returns_By_Ref (Scop_Id); + Compute_Returns_By_Ref (Call_Id); + + Push_Scope (Scop_Id); + Create_Extra_Actuals (Call_Node); + Pop_Scope; + + Remove_Call := True; + end if; + end if; + + -- In order to safely remove these elements from their + -- containing lists, remember these elements before moving + -- to the next list elements. + + if Remove_Call then + declare + Removed_Call : constant Elmt_Id := Elmt_Call; + Removed_Scope : constant Elmt_Id := Elmt_Scope; + + begin + Next_Elmt (Elmt_Scope); + Next_Elmt (Elmt_Call); + + Remove_Elmt (Calls_List, Removed_Call); + Remove_Elmt (Calls_Scope_List, Removed_Scope); + end; + else + Next_Elmt (Elmt_Scope); + Next_Elmt (Elmt_Call); + end if; + + end loop; + end Check_Registered_Calls; + + ------------------------------- + -- Check_Registered_Entities -- + ------------------------------- + + procedure Check_Registered_Entities is + Elmt : Elmt_Id; + Found_Elmt : Elmt_Id; + Id : Entity_Id; + + begin + Elmt := First_Elmt (Entities_List); + + while Present (Elmt) loop + Id := Node (Elmt); + + -- If the underlying type of some formal or return type of this + -- entity is not available then skip this element. + + if not Underlying_Types_Available (Id) then + Next_Elmt (Elmt); + + -- Otherwise, create its extra formals and remove it from the + -- list of entities that require adding the extra formals. + + else + -- In order to safely remove this element from the list, + -- temporarily remember this element, and move to the next + -- element. + + Found_Elmt := Elmt; + Next_Elmt (Elmt); + + -- Create the extra formals, and mark functions that return + -- by reference (not be done before if the underying return + -- type was previously unknown). + + Create_Extra_Formals (Id); + Compute_Returns_By_Ref (Id); + + Remove_Elmt (Entities_List, Found_Elmt); + + -- For deferred entries and entry families, the expansion of + -- their entry declaration was deferred, and must be done + -- now (after adding their extra formals). + + if Ekind (Id) in E_Entry | E_Entry_Family then + Expand_N_Entry_Declaration (Parent (Id), + Was_Deferred => True); + end if; + end if; + end loop; + end Check_Registered_Entities; + + -- Start of processing for Add_Deferred_Extra_Params + + begin + pragma Assert (Present (Underlying_Type (Typ))); + + if Present (Entities_List) then + Check_Registered_Entities; + end if; + + if Present (Calls_List) then + Check_Registered_Calls; + end if; + + Remove (Types_List, Typ); + end Add_Deferred_Extra_Params; + + -------------------------------- + -- Has_Deferred_Extra_Formals -- + -------------------------------- + + function Has_Deferred_Extra_Formals (Typ : Entity_Id) return Boolean is + begin + return Contains (Types_List, Typ); + end Has_Deferred_Extra_Formals; + + -------------------------------------- + -- Is_Deferred_Extra_Formals_Entity -- + -------------------------------------- + + function Is_Deferred_Extra_Formals_Entity + (Id : Entity_Id) return Boolean is + begin + return Contains (Entities_List, Id); + end Is_Deferred_Extra_Formals_Entity; + + --------------------------------------- + -- Is_Unsupported_Extra_Actuals_Call -- + --------------------------------------- + + -- Similarly to Is_Unsupported_Extra_Formals_Entity, we cannot + -- determine if the extra formals are needed when the underlying + -- type of some formal or result type is not available, and we are + -- compiling the body of a subprogram or package. However, for calls + -- we must also handle internal calls generated by the compiler as + -- part of compiling a package spec. For example, internal calls + -- performed in thunks of secondary dispatch table entries. + -- + -- Example + -- ------- + -- package P is + -- type T is tagged null record; + -- end; + -- + -- limited with P; + -- package Q is + -- type Iface is interface; + -- procedure Prim (Self : Iface; Current : P.T) is abstract; + -- end; + -- + -- limited with P; + -- with Q; + -- package R is + -- type Root is tagged null record; + -- type DT is new Root and Q.Iface with null record; + -- + -- procedure Prim (Self : DT; Current : P.T); + -- end; + -- + -- The initialization of the secondary dispatch table of tagged type + -- DT has an internally generated thunk that displaces the pointer to + -- the object and calls the primitive Prim (and the underlying type + -- of type T is not available). + + function Is_Unsupported_Extra_Actuals_Call + (Call_Node : Node_Id; Id : Entity_Id) return Boolean + is + Comp_Unit : constant Entity_Id := + Cunit_Entity (Get_Source_Unit (Call_Node)); + begin + return not Underlying_Types_Available (Id) + and then Is_Compilation_Unit (Comp_Unit) + and then Ekind (Comp_Unit) in E_Package + | E_Package_Body + | E_Subprogram_Body; + end Is_Unsupported_Extra_Actuals_Call; + + ----------------------------------------- + -- Is_Unsupported_Extra_Formals_Entity -- + ----------------------------------------- + + -- We cannot determine if the extra formals are needed when the + -- underlying type of some formal or result type is not available, + -- and we are compiling the body of a subprogram or package. The + -- scenery for this case is a package spec that has a limited_with_ + -- clause on unit Q, and its body has no regular with-clause on Q + -- (AI05-0151-1/08). + + function Is_Unsupported_Extra_Formals_Entity + (Id : Entity_Id) return Boolean + is + Comp_Unit : constant Entity_Id := + Cunit_Entity (Get_Source_Unit (Id)); + begin + return not Underlying_Types_Available (Id) + and then Is_Compilation_Unit (Comp_Unit) + and then Ekind (Comp_Unit) in E_Package_Body + | E_Subprogram_Body; + end Is_Unsupported_Extra_Formals_Entity; + + -------------------------------------------- + -- Register_Deferred_Extra_Formals_Entity -- + -------------------------------------------- + + procedure Register_Deferred_Extra_Formals_Entity (Id : Entity_Id) is + + procedure Register_Type (Typ : Entity_Id); + -- Register the given type in Types_List; for types visible though + -- limited_with_clauses, register their non-limited view. + + ------------------- + -- Register_Type -- + ------------------- + + procedure Register_Type (Typ : Entity_Id) is + begin + -- Handle entities visible through limited_with_clauses + + if Has_Non_Limited_View (Typ) then + Append_Unique_Elmt (Non_Limited_View (Typ), Types_List); + else + Append_Unique_Elmt (Typ, Types_List); + end if; + end Register_Type; + + -- Local variables + + Formal : Entity_Id; + + -- Start of processing for Register_Deferred_Extra_Formals_Entity + + begin + pragma Assert (Is_Subprogram_Or_Entry (Id) + or else Ekind (Id) in E_Subprogram_Type); + + if not Is_Deferred_Extra_Formals_Entity (Id) then + if No (Types_List) then + Types_List := New_Elmt_List; + end if; + + if No (Entities_List) then + Entities_List := New_Elmt_List; + end if; + + -- Register all the types of the subprogram profile that are not + -- fully known. + + Formal := First_Formal (Id); + while Present (Formal) loop + + if No (Underlying_Type (Etype (Formal))) then + Register_Type (Etype (Formal)); + end if; + + Next_Formal (Formal); + end loop; + + if Ekind (Id) in E_Function | E_Subprogram_Type + and then No (Underlying_Type (Etype (Id))) + then + Register_Type (Etype (Id)); + end if; + + -- Register this subprogram + + Append_Elmt (Id, Entities_List); + end if; + end Register_Deferred_Extra_Formals_Entity; + + ------------------------------------------ + -- Register_Deferred_Extra_Formals_Call -- + ------------------------------------------ + + procedure Register_Deferred_Extra_Formals_Call + (Call_Node : Node_Id; + Scope_Id : Entity_Id) is + begin + pragma Assert (Nkind (Call_Node) in N_Subprogram_Call + | N_Entry_Call_Statement); + if No (Calls_List) then + Calls_List := New_Elmt_List; + Calls_Scope_List := New_Elmt_List; + end if; + + -- Avoid registering any call twice; this may occur in dispatching + -- calls with deferred extra actuals because Expand_Call_Helper + -- registers the call and invokes Expand_Dispatching_Call (which + -- tries again to register the expanded call). + + if not Contains (Calls_List, Call_Node) then + Append_Elmt (Call_Node, Calls_List); + Append_Elmt (Scope_Id, Calls_Scope_List); + end if; + end Register_Deferred_Extra_Formals_Call; + + -------------------------------- + -- Underlying_Types_Available -- + -------------------------------- + + function Underlying_Types_Available (E : Entity_Id) return Boolean is + Formal : Entity_Id; + Formal_Typ : Entity_Id; + Func_Typ : Entity_Id; + + begin + -- If the extra formals are available, then the nonlimited view + -- of all the types referenced in the profile are available. + + if Extra_Formals_Known (E) then + return True; + end if; + + -- Check the return type + + if Ekind (E) in E_Function | E_Subprogram_Type then + Func_Typ := Etype (E); + + if Has_Non_Limited_View (Func_Typ) then + Func_Typ := Non_Limited_View (Func_Typ); + end if; + + if No (Underlying_Type (Func_Typ)) then + return False; + end if; + end if; + + -- Check the type of the formals + + Formal := First_Formal (E); + while Present (Formal) loop + Formal_Typ := Etype (Formal); + + if Has_Non_Limited_View (Formal_Typ) then + Formal_Typ := Non_Limited_View (Formal_Typ); + end if; + + if No (Underlying_Type (Formal_Typ)) then + return False; + end if; + + Next_Formal (Formal); + end loop; + + return True; + end Underlying_Types_Available; + + end Deferred_Extra_Formals_Support; + --------------------- -- Process_Formals -- --------------------- diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index 7ebbcaa..4ef5b65 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -190,6 +190,14 @@ package Sem_Ch6 is -- Use the subprogram specification in the body to retrieve the previous -- subprogram declaration, if any. + procedure Freeze_Extra_Formals (E : Entity_Id); + -- Given a subprogram, subprogram type, or entry, flag E to indicate that + -- its extra formals (if any) are known (by setting Extra_Formals_Known). + -- This subprogram serves three purposes: (1) Document the places where + -- the extra formals are known, (2) Ensure that extra formals are added + -- only once, and (3) Provide a convenient place for setting a debugger + -- breakpoint to locate when extra formals are known. + function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; -- Determine whether two callable entities (subprograms, entries, -- literals) are fully conformant (RM 6.3.1(17)) @@ -299,4 +307,156 @@ package Sem_Ch6 is procedure Valid_Operator_Definition (Designator : Entity_Id); -- Verify that an operator definition has the proper number of formals + ------------------------------------ + -- Deferred_Extra_Formals_Support -- + ------------------------------------ + + -- This package provides support for deferring the addition of extra + -- formals to subprograms, entries, and subprogram types; it also provides + -- support for deferring the addition of extra actuals to direct calls to + -- subprograms and entries, and indirect calls through subprogram types. + -- The addition of the extra formals and actuals is deferred until the + -- underlying type of all the parameters and result types of registered + -- subprograms, entries, and subprogram types is known. + + -- Functional Description + -- ---------------------- + -- + -- When Create_Extra_Formals identifies that the underlying type of + -- some parameter or result type of an entity E is not available, E is + -- registered by this package, and the addition of its extra formals is + -- deferred. As part of this registration, the types of all the params + -- and result types of E with no underlying type are also registered. + -- + -- When Expand_Call_Helper identifies that the underlying type of some + -- parameter or result type of a called entity is not available, the call + -- is registered by Register_Deferred_Extra_Formals_Call, and the addition + -- of its extra actuals is deferred. + -- + -- When the full type declaration of some registered type T is analyzed, + -- the subprogram Add_Deferred_Extra_Params is invoked; this subprogram + -- does the following actions: + -- 1) Check all the registered entities (subprograms, entries, and + -- subprogram types); for each registered entity that has all its + -- underlying types available, call Create_Extra_Formals, and + -- unregister the entity. + -- 2) Check all the registered calls; for each registered call that + -- has available the underlying type of all the parameters and result + -- types of the called entity, call Create_Extra_Actuals, and + -- unregister the call. + -- 3) Unregister T. + -- + -- Example 1 + -- --------- + -- A package spec has a private type declaration T, and declarations of + -- expression functions and/or primitives with class-wide conditions + -- invoking primitives of type T before the full view of T is defined. + -- + -- As part of processing the early freezing of the called subprograms + -- (and as part of processing the calls) the functions are registered as + -- subprograms with deferred extra formals, and the calls are registered + -- as calls with deferred extra actuals. + -- + -- When the full type declaration of T is analyzed, extra formals are + -- added to all the registered subprograms, and extra actuals are added + -- to all the registered calls with deferred extra actuals. + -- + -- Example 2 + -- --------- + -- The specification of package P has a limited_with_clause on package Q, + -- and the type of the formals of subprograms defined in P are types + -- defined in Q. + -- + -- When compiling the spec of P, similarly to the previous example, + -- subprograms with incomplete formals are registered as subprograms + -- with deferred extra formals; if the spec of P has calls to these + -- subprograms, then these calls are registered as calls with deferred + -- extra actuals. That is, when the analysis of package P completes, + -- deferred extra formals and actuals have not been added. + -- + -- When another compilation unit is analyzed (including the body of + -- package P), and a regular with-clause on Q is processed, when the + -- full type declaration of deferred entities is analyzed, deferred + -- extra formals and deferred extra actuals are added. + -- + -- This machinery relies on the GNAT Compilation Model; that is, when + -- we analyze the spec of P (for which we generally don't generate code), + -- it is safe to complete the compilation and still have entities with + -- deferred extra formals, and calls with deferred extra actuals. + -- + -- The body package P generally has a regular with-clause on package Q. + -- Hence, when we compile the body of package P, the implicit dependence + -- on its package spec causes the analysis of the spec of P (thus + -- registering deferred entities), followed by the analysis of context + -- clauses in the body of P. When the regular with-clause on package Q + -- is analyzed, we add the extra formals and extra actuals to deferred + -- entities. Thus, the generated code will have all the needed formals. + -- + -- The (still) unsupported case is when the body of package P does not + -- have a regular with-clause on package Q (AI05-0151-1/08). This case + -- is left documented in the front-end sources by means of calls to + -- the following subprograms: Is_Unsupported_Extra_Formals_Entity, and + -- Is_Unsupported_Extra_Actuals_Call. + + package Deferred_Extra_Formals_Support is + + procedure Add_Deferred_Extra_Params (Typ : Entity_Id); + -- Check all the registered subprograms, entries, and subprogram types + -- with deferred addition of their extra formals; if the underlying + -- types of all their formals is available then add their extra formals. + -- Check also all the registered calls with deferred addition of their + -- extra actuals; add their extra actuals if the underlying types of all + -- their parameters and result types are available. Finally unregister + -- Typ from the list of types used for the deferral of extra formals/ + -- actuals. + + procedure Register_Deferred_Extra_Formals_Entity (Id : Entity_Id); + -- Register the given subprogram, entry, or subprogram type to defer the + -- addition of its extra formals. + + procedure Register_Deferred_Extra_Formals_Call + (Call_Node : Node_Id; + Scope_Id : Entity_Id); + -- Register the given call, performed from the given scope, to defer the + -- addition of its extra actuals. + + function Has_Deferred_Extra_Formals (Typ : Entity_Id) return Boolean; + -- Return True if there some registered subprogram, subprogram type, or + -- entry with deferred extra formals that has some formal type or + -- result type of type Typ (i.e. which depends on the given type to + -- add its extra formals). + + function Is_Deferred_Extra_Formals_Entity + (Id : Entity_Id) return Boolean; + -- Return True if Id is a subprogram, subprogram type, or entry that has + -- been registered to defer the addition of its extra formals. + + function Is_Unsupported_Extra_Formals_Entity + (Id : Entity_Id) return Boolean; + -- Id is a subprogram, subprogram type, or entry. Return True if Id is + -- unsupported for deferring the addition of its extra formals; that is, + -- it is defined in a compilation unit that is a package body or a + -- subprogram body, and the underlying type of some of its parameters + -- or result type is not available. + -- + -- The context for this case is an unsupported case of AI05-0151-1/08 + -- that allows incomplete tagged types as parameter and result types. + -- More concretely, a type T is visible in a package spec through a + -- limited_with_clause, and the body of the package has no regular + -- with_clause. In such a case, the machinery for deferring the + -- addition of extra formals does not work because the underlying + -- type of the type is not seen during the compilation of the + -- package body. + -- + -- The purpose of this function is to facilitate locating in the sources + -- the places where the front end performs the current (incomplete) + -- management of such case (to facilitate further work) ??? + + function Is_Unsupported_Extra_Actuals_Call + (Call_Node : Node_Id; Id : Entity_Id) return Boolean; + -- Same as previous function but applicable to a call to the given + -- entity Id. + + end Deferred_Extra_Formals_Support; + end Sem_Ch6; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 54066b4..e6ef658 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -5444,7 +5444,15 @@ package body Sem_Ch8 is elsif In_Open_Scopes (Scope (Base_Type (T))) then null; - elsif not Redundant_Use (Id) then + -- Turn off the use_type_clause on the type unless the clause is + -- redundant, or there's a previous use_type_clause. (The case where + -- a use_type_clause without "all" is followed by one with "all" in + -- a more nested scope is not considered redundant, necessitating + -- the test for a previous clause. One might expect the latter test + -- to suffice, but it turns out there are cases where Redundant_Use + -- is set, but Prev_Use_Clause is not set. ???) + + elsif not Redundant_Use (Id) and then No (Prev_Use_Clause (N)) then Set_In_Use (T, False); Set_In_Use (Base_Type (T), False); Set_Current_Use_Clause (T, Empty); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index e32612e..bf387d3 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -1700,6 +1700,12 @@ package body Sem_Ch9 is Process_Formals (Formals, N); Create_Extra_Formals (Def_Id); End_Scope; + + -- If the entry has no formals, extra formals are definitely not + -- required. + + else + Freeze_Extra_Formals (Def_Id); end if; if Ekind (Def_Id) = E_Entry then diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 9d03eff..5a8bd58 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -2416,6 +2416,8 @@ package body Sem_Disp is Formal : Entity_Id; Ctrl_Type : Entity_Id; + -- Start of processing for Find_Dispatching_Type + begin if Ekind (Subp) in E_Function | E_Procedure and then Present (DTC_Entity (Subp)) @@ -3083,6 +3085,52 @@ package body Sem_Disp is then return Is_Tag_Indeterminate (Prefix (Orig_Node)); + -- An if-expression is tag-indeterminate if all of the dependent + -- expressions are tag-indeterminate (RM 4.5.7 (17/3)). + + elsif Nkind (Orig_Node) = N_If_Expression then + declare + Cond : constant Node_Id := First (Expressions (Orig_Node)); + Expr : Node_Id := Next (Cond); + + begin + if not Is_Tag_Indeterminate (Original_Node (Expr)) then + return False; + end if; + + Next (Expr); + + if Present (Expr) + and then not Is_Tag_Indeterminate (Original_Node (Expr)) + then + return False; + end if; + + return True; + end; + + -- A case-expression is tag-indeterminate if all of the dependent + -- expressions are tag-indeterminate (RM 4.5.7 (17/3)). + + elsif Nkind (Orig_Node) = N_Case_Expression then + declare + Alt : Node_Id := First (Alternatives (Orig_Node)); + Expr : Node_Id; + + begin + while Present (Alt) loop + Expr := Expression (Alt); + + if not Is_Tag_Indeterminate (Original_Node (Expr)) then + return False; + end if; + + Next (Alt); + end loop; + + return True; + end; + else return False; end if; @@ -3243,6 +3291,7 @@ package body Sem_Disp is elsif Nkind (Actual) = N_Explicit_Dereference and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call then + pragma Assert (Is_Expanded_Dispatching_Call (Actual)); return; -- When expansion is suppressed, an unexpanded call to 'Input can occur, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index e44994a..29b7766 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7270,7 +7270,9 @@ package body Sem_Res is if Restriction_Check_Required (No_Relative_Delay) and then Is_RTE (Nam, RE_Set_Handler) - and then Is_RTE (Etype (Next_Actual (First_Actual (N))), RE_Time_Span) + and then + Is_RTE + (Base_Type (Etype (Next_Actual (First_Actual (N)))), RE_Time_Span) then Check_Restriction (No_Relative_Delay, N); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 74de26a..b2b4fed 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -35,6 +35,7 @@ with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; with Fname; use Fname; with Freeze; use Freeze; +with Ghost; use Ghost; with Itypes; use Itypes; with Lib; use Lib; with Lib.Xref; use Lib.Xref; @@ -1923,6 +1924,10 @@ package body Sem_Util is -- Build_Elaboration_Entity -- ------------------------------ + -- WARNING: This routine manages Ghost regions. Return statements must be + -- replaced by gotos which jump to the end of the routine and restore the + -- Ghost mode. + procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); Decl : Node_Id; @@ -1956,6 +1961,12 @@ package body Sem_Util is end if; end Set_Package_Name; + -- Local variables + + Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; + Saved_IGR : constant Node_Id := Ignored_Ghost_Region; + -- Save the Ghost-related attributes to restore on exit + -- Start of processing for Build_Elaboration_Entity begin @@ -2003,6 +2014,11 @@ package body Sem_Util is return; end if; + -- Elaboration entity is never a ghost object, regardless of the context + -- in which this routine is called. + + Install_Ghost_Region (None, N); + -- Here we need the elaboration entity -- Construct name of elaboration entity as xxx_E, where xxx is the unit @@ -2043,6 +2059,8 @@ package body Sem_Util is Set_Has_Qualified_Name (Elab_Ent); Set_Has_Fully_Qualified_Name (Elab_Ent); + + Restore_Ghost_Region (Saved_GM, Saved_IGR); end Build_Elaboration_Entity; -------------------------------- @@ -3688,6 +3706,7 @@ package body Sem_Util is Aspect_Aggregate, Aspect_Max_Entry_Queue_Length -- , Aspect_No_Controlled_Parts + -- , Aspect_No_Task_Parts ); -- Note that none of these 8 aspects can be specified (for a type) @@ -10043,16 +10062,19 @@ package body Sem_Util is and then not Has_Unknown_Discriminants (Utyp) and then not (Ekind (Utyp) = E_String_Literal_Subtype) then - -- Nothing to do if in spec expression (why not???) + -- If the type has no discriminants, there is no subtype to build, + -- even if the underlying type is discriminated. - if In_Spec_Expression then + if Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then return Typ; - elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then - - -- If the type has no discriminants, there is no subtype to - -- build, even if the underlying type is discriminated. + -- If we are performing preanalysis on a conjured-up copy of a name + -- (see calls to Preanalyze_Range in sem_ch5.adb) then we don't want + -- to freeze Atyp, now or ever. In this case, the tree we eventually + -- pass to the back end should contain no references to Atyp (and a + -- freeze node would contain such a reference). + elsif not (Expander_Active or GNATprove_Mode) then return Typ; -- Else build the actual subtype @@ -10068,42 +10090,21 @@ package body Sem_Util is Atyp := Defining_Identifier (Decl); - -- If Build_Actual_Subtype generated a new declaration then use it - - if Atyp /= Typ then - - -- The actual subtype is an Itype, so analyze the declaration, - -- but do not attach it to the tree, to get the type defined. - - Set_Parent (Decl, N); - Set_Is_Itype (Atyp); - Analyze (Decl, Suppress => All_Checks); - Set_Associated_Node_For_Itype (Atyp, N); - if Expander_Active then - Set_Has_Delayed_Freeze (Atyp, False); - - -- We need to freeze the actual subtype immediately. This is - -- needed because otherwise this Itype will not get frozen - -- at all; it is always safe to freeze on creation because - -- any associated types must be frozen at this point. + -- The actual subtype is an Itype, so analyze the declaration + -- after attaching it to the tree, to get the type defined. - -- On the other hand, if we are performing preanalysis on - -- a conjured-up copy of a name (see calls to - -- Preanalyze_Range in sem_ch5.adb) then we don't want - -- to freeze Atyp, now or ever. In this case, the tree - -- we eventually pass to the back end should contain no - -- references to Atyp (and a freeze node would contain - -- such a reference). That's why Expander_Active is tested. + Set_Parent (Decl, N); + Set_Is_Itype (Atyp); + Analyze (Decl, Suppress => All_Checks); + Set_Associated_Node_For_Itype (Atyp, N); - Freeze_Itype (Atyp, N); - end if; - return Atyp; - - -- Otherwise we did not build a declaration, so return original + -- We need to freeze the actual subtype immediately. This is + -- needed because otherwise this Itype will not get frozen + -- at all; it is always safe to freeze on creation because + -- any associated types must be frozen at this point. - else - return Typ; - end if; + Freeze_Itype (Atyp, N); + return Atyp; end if; -- For all remaining cases, the actual subtype is the same as @@ -15017,6 +15018,7 @@ package body Sem_Util is | Aspect_Iterator_Element | Aspect_Max_Entry_Queue_Length | Aspect_No_Controlled_Parts + | Aspect_No_Task_Parts => return; end case; @@ -16276,8 +16278,9 @@ package body Sem_Util is Names_Match (Assign_Indexed_1, Assign_Indexed_2); end; - -- Checking for this aspect is performed elsewhere during freezing - when Aspect_No_Controlled_Parts => + -- Checking for these aspects is performed elsewhere during freezing + when Aspect_No_Controlled_Parts + | Aspect_No_Task_Parts => return True; -- scalar-valued aspects; compare (static) values. @@ -21373,6 +21376,18 @@ package body Sem_Util is return False; end Is_Unchecked_Conversion_Instance; + --------------------------------- + -- Is_Unchecked_Union_Equality -- + --------------------------------- + + function Is_Unchecked_Union_Equality (Id : Entity_Id) return Boolean is + begin + return Ekind (Id) = E_Function + and then Present (First_Formal (Id)) + and then Is_Unchecked_Union (Etype (First_Formal (Id))) + and then Id = TSS (Etype (First_Formal (Id)), TSS_Composite_Equality); + end Is_Unchecked_Union_Equality; + ------------------------------- -- Is_Universal_Numeric_Type -- ------------------------------- @@ -26955,6 +26970,10 @@ package body Sem_Util is if Has_Relaxed_Finalization (From_Typ) then Set_Has_Relaxed_Finalization (Typ); end if; + + if Deriv and then Has_Destructor (From_Typ) then + Set_Has_Destructor (Typ); + end if; end Propagate_Controlled_Flags; ------------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index efeafda..4554f24 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1578,7 +1578,7 @@ package Sem_Util is -- underlying type). function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean; - -- Returns true if the last character of E is Suffix. Used in Assertions. + -- Returns true if the last character of E is Suffix. function Has_Tagged_Component (Typ : Entity_Id) return Boolean; -- Returns True if Typ is a composite type (array or record) that is either @@ -2131,7 +2131,7 @@ package Sem_Util is -- object as per RM C.6(8). function Is_Inherited_Operation (E : Entity_Id) return Boolean; - -- E is a subprogram. Return True is E is an implicit operation inherited + -- E is a subprogram. Return True if E is an implicit operation inherited -- by a derived type declaration. function Is_Inlinable_Expression_Function (Subp : Entity_Id) return Boolean; @@ -2196,7 +2196,7 @@ package Sem_Util is -- the encapsulated expression is nontrivial. function Is_Null_Extension - (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean; + (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean; -- Given a tagged type, returns True if argument is a type extension -- that introduces no new components (discriminant or nondiscriminant). -- Ignore_Privacy should be True for use in implementing dynamic semantics. @@ -2449,6 +2449,10 @@ package Sem_Util is -- Determine whether an arbitrary entity denotes an instance of function -- Ada.Unchecked_Conversion. + function Is_Unchecked_Union_Equality (Id : Entity_Id) return Boolean; + -- Determine whether an arbitrary entity denotes the predefined equality + -- function of an Unchecked_Union type (see Build_Variant_Record_Equality). + function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean; -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of -- pragma Depends. Determine whether the type of dependency item Item is @@ -2973,11 +2977,11 @@ package Sem_Util is Comp : Boolean := False; Deriv : Boolean := False); -- Set Disable_Controlled, Finalize_Storage_Only, Has_Controlled_Component, - -- Has_Relaxed_Finalization, and Is_Controlled_Active on Typ when the flags - -- are set on From_Typ. If Comp is True, From_Typ is assumed to be the type - -- of a component of Typ while, if Deriv is True, From_Typ is assumed to be - -- the parent type of Typ. This procedure can only set flags for Typ, and - -- never clear them. + -- Has_Destructor, Has_Relaxed_Finalization, and Is_Controlled_Active on + -- Typ when the flags are set on From_Typ. If Comp is True, From_Typ is + -- assumed to be the type of a component of Typ while, if Deriv is True, + -- From_Typ is assumed to be the parent type of Typ. This procedure can + -- only set flags for Typ, and never clear them. procedure Propagate_DIC_Attributes (Typ : Entity_Id; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index c63a97d..3d11d5c 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -402,16 +402,17 @@ package Sinfo is -- Has_Secondary_Private_View set in generic units -- "plus fields for expression" - -- Paren_Count number of parentheses levels - -- Etype type of the expression - -- Is_Overloaded >1 type interpretation exists - -- Is_Static_Expression set for static expression - -- Raises_Constraint_Error evaluation raises CE - -- Must_Not_Freeze set if must not freeze - -- Do_Range_Check set if a range check needed - -- Has_Dynamic_Length_Check set if length check inserted - -- Assignment_OK set if modification is OK - -- Is_Controlling_Actual set for controlling argument + -- Paren_Count number of parentheses levels + -- Etype type of the expression + -- Is_Overloaded >1 type interpretation exists + -- Is_Static_Expression set for static expression + -- Raises_Constraint_Error evaluation raises CE + -- Must_Not_Freeze set if must not freeze + -- Do_Range_Check set if a range check needed + -- Has_Dynamic_Length_Check set if length check inserted + -- Assignment_OK set if modification is OK + -- Is_Controlling_Actual set for controlling argument + -- Is_Expanded_Dispatching_Call set for expanded dispatching calls -- Note: see under (EXPRESSION) for further details on the use of -- the Paren_Count field to record the number of parentheses levels. @@ -1664,6 +1665,10 @@ package Sinfo is -- actuals to support a build-in-place style of call have been added to -- the call. + -- Is_Expanded_Dispatching_Call + -- This flag is set in N_Block_Statement, and expression nodes to + -- indicate that it is an expanded dispatching call. + -- Is_Expanded_Prefixed_Call -- This flag is set in N_Function_Call and N_Procedure_Call_Statement -- nodes to indicate that it is an expanded prefixed call. @@ -2321,6 +2326,13 @@ package Sinfo is -- statement applies to. Finally, if Analyze_Continue_Statement detects -- an error, this field is set to Empty. + -- Tag_Propagated + -- This flag is set in N_Identifier, N_Explicit_Dereference, and N_Type_ + -- Conversion nodes that are the LHS of an assignment statement. Used to + -- remember that the RHS of the assignment has tag indeterminate function + -- calls and the tag has been propagated to the calls (as part of the + -- bottom-up analysis of the RHS of the assignment statement). + -- Target_Type -- Used in an N_Validate_Unchecked_Conversion node to point to the target -- type entity for the unchecked conversion instantiation which gigi must @@ -2507,6 +2519,7 @@ package Sinfo is -- Has_Private_View (set in generic units) -- Has_Secondary_Private_View (set in generic units) -- Redundant_Use + -- Tag_Propagated -- Atomic_Sync_Required -- plus fields for expression @@ -3820,6 +3833,7 @@ package Sinfo is -- Prefix -- Actual_Designated_Subtype -- Has_Dereference_Action + -- Tag_Propagated -- Atomic_Sync_Required -- plus fields for expression @@ -4755,6 +4769,7 @@ package Sinfo is -- Conversion_OK -- Do_Overflow_Check -- Rounded_Result + -- Tag_Propagated -- plus fields for expression -- Note: if a range check is required, then the Do_Range_Check flag @@ -5196,6 +5211,7 @@ package Sinfo is -- Has_Created_Identifier -- Is_Abort_Block -- Is_Asynchronous_Call_Block + -- Is_Expanded_Dispatching_Call -- Is_Initialization_Block -- Is_Task_Allocation_Block -- Is_Task_Master diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index f26515e..272e10b 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -151,6 +151,7 @@ package Snames is Name_Default_Value : constant Name_Id := N + $; Name_Default_Component_Value : constant Name_Id := N + $; Name_Designated_Storage_Model : constant Name_Id := N + $; + Name_Destructor : constant Name_Id := N + $; Name_Dimension : constant Name_Id := N + $; Name_Dimension_System : constant Name_Id := N + $; Name_Disable_Controlled : constant Name_Id := N + $; diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index 7b7f252..20945fb 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -499,7 +499,8 @@ package body Styleg is if Is_Box_Comment or else Style_Check_Comments_Spacing = 1 then - Error_Space_Required (Scan_Ptr + 2); + Error_Msg -- CODEFIX + ("(style) space required?c?", Scan_Ptr + 2); else Error_Msg -- CODEFIX ("(style) two spaces required?c?", Scan_Ptr + 2); @@ -526,7 +527,8 @@ package body Styleg is -- box comment. elsif not Is_Box_Comment then - Error_Space_Required (Scan_Ptr + 3); + Error_Msg -- CODEFIX + ("(style) space required?c?", Scan_Ptr + 3); end if; end if; end Check_Comment; diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 3dc76f9..afbb362 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -40,6 +40,12 @@ - either they are defined as ENOENT (vx7r2); - or the corresponding system includes are not provided (Helix Cert). */ +#if __has_include ("strings.h") +/* On VxWorks6, FD_ZERO uses bzero, and index is also declared in strings.h, + but since it's not a standard header, don't require it. */ +#include "strings.h" +#endif + #if __has_include ("dosFsLib.h") /* On helix-cert, this include is only provided for RTPs. */ #include "dosFsLib.h" diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index b89c408..52fdbfc 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -926,11 +926,11 @@ package body Tbuild is -- conversion of an unchecked conversion. Extra unchecked conversions -- make the .dg output less readable. We can't do this in cases -- involving bitfields, because the sizes might not match. The - -- "not Is_Scalar_Type" checks avoid such cases. + -- Is_Composite_Type checks avoid such cases. elsif Nkind (Expr) = N_Unchecked_Type_Conversion - and then not Is_Scalar_Type (Etype (Expr)) - and then not Is_Scalar_Type (Typ) + and then Is_Composite_Type (Etype (Expr)) + and then Is_Composite_Type (Typ) then Set_Subtype_Mark (Expr, New_Occurrence_Of (Typ, Loc)); Result := Relocate_Node (Expr); |