ada: Fix unnecessary extra RE_Activation_Chain_Access with No_Task_Parts

This patch checks the presence of No_Task_Parts on any ancestor or
inherited interface, not only its root type, since No_Task_Parts
prohibits tasking for any of its descendant. In case the current
subprogram is overridden/inherited, we need to return the same value
we would return for the original corresponding operation. The aspect
No_Task_Parts is nonoverridable and applies also when specified in a
partial view.

gcc/ada/ChangeLog:

	* 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.

diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index d8861bf8fd008783d1edd4f9fbffe032becfc5d4..6d37ec7bf2ae7dc46e7df1c5cc15e34fee28e898 100644 (file)
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -259,6 +259,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;

diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 8a1cac0451d57cc2578257cbb343ce722a94f45b..162de654323fdc72f64bfa62837244ab8e6307c4 100644 (file)
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -5064,6 +5064,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

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index a13f4bd97df146733115ae7ad73606b95bf7b678..ce5b800e48c955b7b9546052f27fe3ca800082bd 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -8647,7 +8647,16 @@ package body Sem_Ch6 is
 
       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
@@ -8675,21 +8684,28 @@ 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.
+
+         else
+            Subp_Id := Original_Corresponding_Operation (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;
 
       -------------------------------------

diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 9d03eff55c763ac0c7bf771fc4702f0e184d1745..b70c7b4fea44e8ff17c3d3846abb4b53aa12561f 100644 (file)
--- 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))

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index bdbfea86ce02a9d4692cd2b6883d8ded38daa1c2..8ceba7318a9b24c36c6c06d8e93e2c4dc894cfcd 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -3706,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)
@@ -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.

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index b872180201ee0a5baa57e6f250151e4d574cd680..943af8b5b142a5925bffd95482a150bac1c68d86 100644 (file)
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -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.