https://gcc.gnu.org/g:a1bec0455fb6f871bbc2c80d6e19c90deebbf824
commit r14-10298-ga1bec0455fb6f871bbc2c80d6e19c90deebbf824
Author: Javier Miranda <mira...@adacore.com>
Date: Thu Apr 18 09:54:22 2024 +0000
ada: Storage_Error in indirect call to function returning limited type
At runtime the code generated by the compiler reports the
exception Storage_Error in an indirect call through an
access-to-subprogram variable that references a function
returning a limited tagged type object.
gcc/ada/
* sem_ch6.adb (Might_Need_BIP_Task_Actuals): Add support
for access-to-subprogram parameter types.
* exp_ch6.adb (Add_Task_Actuals_To_Build_In_Place_Call):
Add dummy BIP parameters to access-to-subprogram types
that may reference a function that has BIP parameters.
Diff:
---
gcc/ada/exp_ch6.adb | 11 ++++++++---
gcc/ada/sem_ch6.adb | 12 +++++++-----
2 files changed, 15 insertions(+), 8 deletions(-)
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index ad56cfd6e7e..621be2d78cf 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -646,15 +646,20 @@ package body Exp_Ch6 is
Master_Formal : Node_Id;
begin
+ pragma Assert (Ekind (Function_Id) in E_Function
+ | E_Subprogram_Type);
+
-- No such extra parameters are needed if there are no tasks
if not Needs_BIP_Task_Actuals (Function_Id) then
-- However we must add dummy extra actuals if the function is
- -- a dispatching operation that inherited these extra formals.
+ -- a dispatching operation that inherited these extra formals
+ -- or an access-to-subprogram type that requires these extra
+ -- actuals.
- if Is_Dispatching_Operation (Function_Id)
- and then Has_BIP_Extra_Formal (Function_Id, BIP_Task_Master)
+ if Has_BIP_Extra_Formal (Function_Id, BIP_Task_Master,
+ Must_Be_Frozen => False)
then
Master_Formal :=
Build_In_Place_Formal (Function_Id, BIP_Task_Master);
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index fb43b044842..4f33e74e4a9 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -8660,9 +8660,12 @@ package body Sem_Ch6 is
-- 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).
+ -- Determines if E is a function or an access to a function returning a
+ -- limited tagged type object. On dispatching primitives this predicate
+ -- is used to determine if some descendant of the function might return
+ -- an object with tasks (and therefore need the BIP task extra actuals).
+ -- On access-to-subprogram types it is used to determine if the target
+ -- function might return an object with tasks.
function Needs_Accessibility_Check_Extra
(E : Entity_Id;
@@ -8783,9 +8786,8 @@ package body Sem_Ch6 is
Func_Typ := Root_Type (Underlying_Type (Etype (Subp_Id)));
- return Ekind (Subp_Id) = E_Function
+ return Ekind (Subp_Id) in E_Function | E_Subprogram_Type
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);
