From: Eric Botcazou <[email protected]>
This occurs when the operator has a heterogeneous profile and the extension
is declared in the same scope as the type of a non-controlling parameter of
the operator, because Find_Dispatching_Type incorrectly returns this type.
gcc/ada/ChangeLog:
* exp_ch3.adb (Make_Controlling_Function_Wrappers): Manually set the
Has_Controlling_Result flag on the wrappers.
* sem_disp.ads (Override_Dispatching_Operation): Move to...
* sem_disp.adb (Override_Dispatching_Operation): ...here.
(Find_Dispatching_Type): Return the (controlling) result type for a
controlling function wrapper.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch3.adb | 1 +
gcc/ada/sem_disp.adb | 16 ++++++++++++++++
gcc/ada/sem_disp.ads | 8 --------
3 files changed, 17 insertions(+), 8 deletions(-)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 0e83b9b5854..73d37dea315 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -11693,6 +11693,7 @@ package body Exp_Ch3 is
Func_Id := Defining_Unit_Name (Specification (Func_Decl));
Mutate_Ekind (Func_Id, E_Function);
+ Set_Has_Controlling_Result (Func_Id);
Set_Is_Wrapper (Func_Id);
-- Corresponding_Spec will be set again to the same value during
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index dfcf384c7da..f69e7959ee5 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -96,6 +96,14 @@ package body Sem_Disp is
-- Check whether a primitive operation is inherited from an operation
-- declared in the visible part of its package.
+ procedure Override_Dispatching_Operation
+ (Tagged_Type : Entity_Id;
+ Prev_Op : Entity_Id;
+ New_Op : Entity_Id);
+ -- Replace an implicit dispatching operation of the type Tagged_Type
+ -- with an explicit one. Prev_Op is an inherited primitive operation which
+ -- is overridden by the explicit declaration of New_Op.
+
-------------------------------
-- Add_Dispatching_Operation --
-------------------------------
@@ -2433,6 +2441,14 @@ package body Sem_Disp is
return Empty;
end if;
+ -- Deal with controlling function wrappers
+
+ elsif Ekind (Subp) = E_Function
+ and then Has_Controlling_Result (Subp)
+ and then Is_Wrapper (Subp)
+ then
+ return Check_Controlling_Type (Etype (Subp), Subp);
+
-- General case
else
diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads
index f1bf4c4ded9..31a5824bfbb 100644
--- a/gcc/ada/sem_disp.ads
+++ b/gcc/ada/sem_disp.ads
@@ -173,14 +173,6 @@ package Sem_Disp is
-- controlling operands are also indeterminate. Such a function call may
-- inherit a tag from an enclosing call.
- procedure Override_Dispatching_Operation
- (Tagged_Type : Entity_Id;
- Prev_Op : Entity_Id;
- New_Op : Entity_Id);
- -- Replace an implicit dispatching operation of the type Tagged_Type
- -- with an explicit one. Prev_Op is an inherited primitive operation which
- -- is overridden by the explicit declaration of New_Op.
-
procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id);
-- If a function call given by Actual is tag-indeterminate, its controlling
-- argument is found in the context, given by Control: either from an
--
2.53.0
