aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/sem_ch6.adb
diff options
context:
space:
mode:
authorJavier Miranda <miranda@adacore.com>2023-07-09 17:34:18 +0000
committerMarc Poulhiès <poulhies@adacore.com>2023-07-28 09:28:15 +0200
commit358e289d37b011ff113f5c70dee777c15679743a (patch)
tree4deeece59a26a58b73559b964efb0affc39a14c2 /gcc/ada/sem_ch6.adb
parentf74de746a79712e64962b03ab9ec7beebdec153a (diff)
downloadgcc-358e289d37b011ff113f5c70dee777c15679743a.zip
gcc-358e289d37b011ff113f5c70dee777c15679743a.tar.gz
gcc-358e289d37b011ff113f5c70dee777c15679743a.tar.bz2
ada: Fix unsupported dispatching constructor call
Add dummy build-in-place parameters when a BIP function does not require the BIP parameters but it is a dispatching operation that inherited them. gcc/ada/ * einfo-utils.adb (Underlying_Type): Protect recursion call against non-available attribute Etype. * einfo.ads (Protected_Subprogram): Fix typo in documentation. * exp_ch3.adb (BIP_Function_Call_Id): New subprogram. (Expand_N_Object_Declaration): Improve code that evaluates if the object is initialized with a BIP function call. * exp_ch6.adb (Is_True_Build_In_Place_Function_Call): New subprogram. (Add_Task_Actuals_To_Build_In_Place_Call): Add dummy actuals if the function does not require the BIP task actuals but it is a dispatching operation that inherited them. (Build_In_Place_Formal): Improve code to avoid never-ending loop if the BIP formal is not found. (Add_Dummy_Build_In_Place_Actuals): New subprogram. (Expand_Call_Helper): Add calls to Add_Dummy_Build_In_Place_Actuals. (Expand_N_Extended_Return_Statement): Adjust assertion. (Expand_Simple_Function_Return): Adjust assertion. (Make_Build_In_Place_Call_In_Allocator): No action needed if the called function inherited the BIP extra formals but it is not a true BIP function. (Make_Build_In_Place_Call_In_Assignment): Ditto. * exp_intr.adb (Expand_Dispatching_Constructor_Call): Remove code reporting unsupported case (since this patch adds support for it). * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Adding assertion to ensure matching of BIP formals when setting the Protected_Formal field of a protected subprogram to reference the corresponding extra formal of the subprogram that implements it. (Might_Need_BIP_Task_Actuals): New subprogram. (Create_Extra_Formals): Improve code adding inherited extra formals.
Diffstat (limited to 'gcc/ada/sem_ch6.adb')
-rw-r--r--gcc/ada/sem_ch6.adb185
1 files changed, 108 insertions, 77 deletions
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 4e64833..53011f4 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -53,6 +53,7 @@ with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
+with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
@@ -4457,6 +4458,10 @@ package body Sem_Ch6 is
begin
while Present (Prot_Ext_Formal) loop
pragma Assert (Present (Impl_Ext_Formal));
+ pragma Assert (not Is_Build_In_Place_Entity (Prot_Ext_Formal)
+ or else BIP_Suffix_Kind (Impl_Ext_Formal)
+ = BIP_Suffix_Kind (Prot_Ext_Formal));
+
Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal);
Next_Formal_With_Extras (Prot_Ext_Formal);
Next_Formal_With_Extras (Impl_Ext_Formal);
@@ -8581,6 +8586,11 @@ package body Sem_Ch6 is
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 dispatching primitive returning a limited tagged
+ -- type object since some descendant might return an object with tasks
+ -- (and therefore need the BIP task extra actuals).
+
function Needs_Accessibility_Check_Extra
(E : Entity_Id;
Formal : Node_Id) return Boolean;
@@ -8656,6 +8666,58 @@ package body Sem_Ch6 is
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;
+
+ begin
+ if Global_No_Tasking or else No_Run_Time_Mode then
+ return False;
+ end if;
+
+ -- No further check needed if we know that BIP task actuals are
+ -- required.
+
+ if Needs_BIP_Task_Actuals (E) then
+ return True;
+ end if;
+
+ -- For thunks we must rely on their target entity
+
+ if Is_Thunk (E) then
+ Subp_Id := Thunk_Target (E);
+
+ -- For protected subprograms we rely on the subprogram which
+ -- implements the body of the operation (since it is the entity
+ -- that may be a dispatching operation).
+
+ elsif Is_Protected_Type (Scope (E))
+ and then Present (Protected_Body_Subprogram (E))
+ then
+ Subp_Id := Protected_Body_Subprogram (E);
+
+ else
+ 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.
+
+ Func_Typ := Root_Type (Underlying_Type (Etype (Subp_Id)));
+
+ return Ekind (Subp_Id) = E_Function
+ and then not Has_Foreign_Convention (Func_Typ)
+ and then Is_Dispatching_Operation (Subp_Id)
+ 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);
+ end Might_Need_BIP_Task_Actuals;
+
-------------------------------------
-- Needs_Accessibility_Check_Extra --
-------------------------------------
@@ -8790,7 +8852,8 @@ package body Sem_Ch6 is
then
return;
- -- Initialization procedures don't have extra formals
+ -- Extra formals of Initialization procedures are added by the function
+ -- Exp_Ch3.Init_Formals
elsif Is_Init_Proc (E) then
return;
@@ -9076,20 +9139,16 @@ package body Sem_Ch6 is
begin
Ada_Version := Ada_2022;
- if Needs_Result_Accessibility_Level (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Needs_Result_Accessibility_Level (Parent_Subp));
- pragma Assert (No (Alias_Subp)
- or else Needs_Result_Accessibility_Level (Alias_Subp));
-
+ if Needs_Result_Accessibility_Level (Ref_E)
+ or else
+ (Present (Parent_Subp)
+ and then Needs_Result_Accessibility_Level (Parent_Subp))
+ or else
+ (Present (Alias_Subp)
+ and then Needs_Result_Accessibility_Level (Alias_Subp))
+ then
Set_Extra_Accessibility_Of_Result (E,
Add_Extra_Formal (E, Standard_Natural, E, "L"));
-
- else
- pragma Assert (No (Parent_Subp)
- or else not Needs_Result_Accessibility_Level (Parent_Subp));
- pragma Assert (No (Alias_Subp)
- or else not Needs_Result_Accessibility_Level (Alias_Subp));
end if;
Ada_Version := Save_Ada_Version;
@@ -9124,14 +9183,16 @@ package body Sem_Ch6 is
-- dispatching context and such calls must be handled like calls
-- to a class-wide function.
- if Needs_BIP_Alloc_Form (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Has_BIP_Extra_Formal (Parent_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else Has_BIP_Extra_Formal (Alias_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
-
+ if Needs_BIP_Alloc_Form (Ref_E)
+ or else
+ (Present (Parent_Subp)
+ and then Has_BIP_Extra_Formal (Parent_Subp, BIP_Alloc_Form,
+ Must_Be_Frozen => False))
+ or else
+ (Present (Alias_Subp)
+ and then Has_BIP_Extra_Formal (Alias_Subp, BIP_Alloc_Form,
+ Must_Be_Frozen => False))
+ then
Discard :=
Add_Extra_Formal
(E, Standard_Natural,
@@ -9147,87 +9208,57 @@ package body Sem_Ch6 is
(E, RTE (RE_Root_Storage_Pool_Ptr),
E, BIP_Formal_Suffix (BIP_Storage_Pool));
end if;
-
- else
- pragma Assert (No (Parent_Subp)
- or else not
- Has_BIP_Extra_Formal (Parent_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else not
- Has_BIP_Extra_Formal (Alias_Subp, BIP_Alloc_Form,
- Must_Be_Frozen => False));
end if;
-- In the case of functions whose result type needs finalization,
-- add an extra formal which represents the finalization master.
- if Needs_BIP_Finalization_Master (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Has_BIP_Extra_Formal (Parent_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else Has_BIP_Extra_Formal (Alias_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
-
+ if Needs_BIP_Finalization_Master (Ref_E)
+ or else
+ (Present (Parent_Subp)
+ and then Has_BIP_Extra_Formal (Parent_Subp,
+ Kind => BIP_Finalization_Master,
+ Must_Be_Frozen => False))
+ or else
+ (Present (Alias_Subp)
+ and then Has_BIP_Extra_Formal (Alias_Subp,
+ Kind => BIP_Finalization_Master,
+ Must_Be_Frozen => False))
+ then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Finalization_Master_Ptr),
E, BIP_Formal_Suffix (BIP_Finalization_Master));
-
- else
- pragma Assert (No (Parent_Subp)
- or else not
- Has_BIP_Extra_Formal (Parent_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else not
- Has_BIP_Extra_Formal (Alias_Subp,
- Kind => BIP_Finalization_Master,
- Must_Be_Frozen => False));
end if;
-- When the result type contains tasks, add two extra formals: the
-- master of the tasks to be created, and the caller's activation
-- chain.
- if Needs_BIP_Task_Actuals (Ref_E) then
- pragma Assert (No (Parent_Subp)
- or else Has_BIP_Extra_Formal (Parent_Subp, BIP_Task_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else Has_BIP_Extra_Formal (Alias_Subp, BIP_Task_Master,
- Must_Be_Frozen => False)
- or else
- (Is_Abstract_Subprogram (Ref_E)
- and then Is_Predefined_Dispatching_Operation (Ref_E)
- and then Is_Interface
- (Find_Dispatching_Type (Alias_Subp))));
-
+ if Needs_BIP_Task_Actuals (Ref_E)
+ or else Might_Need_BIP_Task_Actuals (Ref_E)
+ or else
+ (Present (Parent_Subp)
+ and then Has_BIP_Extra_Formal (Parent_Subp, BIP_Task_Master,
+ Must_Be_Frozen => False))
+ or else
+ (Present (Alias_Subp)
+ and then Has_BIP_Extra_Formal (Alias_Subp, BIP_Task_Master,
+ Must_Be_Frozen => False))
+ then
Discard :=
Add_Extra_Formal
(E, Standard_Integer,
E, BIP_Formal_Suffix (BIP_Task_Master));
- Set_Has_Master_Entity (E);
+ if Needs_BIP_Task_Actuals (Ref_E) then
+ Set_Has_Master_Entity (E);
+ end if;
Discard :=
Add_Extra_Formal
(E, RTE (RE_Activation_Chain_Access),
E, BIP_Formal_Suffix (BIP_Activation_Chain));
-
- else
- pragma Assert (No (Parent_Subp)
- or else not
- Has_BIP_Extra_Formal (Parent_Subp, BIP_Task_Master,
- Must_Be_Frozen => False));
- pragma Assert (No (Alias_Subp)
- or else not
- Has_BIP_Extra_Formal (Alias_Subp, BIP_Task_Master,
- Must_Be_Frozen => False));
end if;
-- All build-in-place functions get an extra formal that will be