From: Denis Mazzucato <mazzuc...@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.ads | 1 +
gcc/ada/sem_ch13.adb | 8 ++++++++
gcc/ada/sem_ch6.adb | 38 +++++++++++++++++++++++++++-----------
gcc/ada/sem_disp.adb | 2 ++
gcc/ada/sem_util.adb | 7 +++++--
gcc/ada/sem_util.ads | 4 ++--
6 files changed, 45 insertions(+), 15 deletions(-)
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index d8861bf8fd0..6d37ec7bf2a 100644
--- 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 8a1cac0451d..162de654323 100644
--- 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 a13f4bd97df..ce5b800e48c 100644
--- 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;
+
+ -- 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;
- -- We check the root type of the return type since the same
- -- decision must be taken for all descendants overriding a
- -- dispatching operation.
-
- 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 9d03eff55c7..b70c7b4fea4 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))
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index bdbfea86ce0..8ceba7318a9 100644
--- 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 b872180201e..943af8b5b14 100644
--- 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.
--
2.43.0
