[gcc r16-8307] Ada: Fix overriding indicator wrongly rejected on protected procedure
Eric Botcazou
ebotcazou@gcc.gnu.org
Fri Mar 27 17:40:15 GMT 2026
https://gcc.gnu.org/g:2e1284494952d777178386b50048d0d89fa7bb00
commit r16-8307-g2e1284494952d777178386b50048d0d89fa7bb00
Author: Eric Botcazou <ebotcazou@adacore.com>
Date: Fri Mar 27 18:38:09 2026 +0100
Ada: Fix overriding indicator wrongly rejected on protected procedure
The case itself is fairly pathological (and very likely not human made), but
it's a clear incentive to get rid of an old kludge in generic instantiation,
whereby the full view of a type is forced on nodes in the generic unit even
though only the partial declaration is visible to them.
gcc/ada/
PR ada/124596
* sem_ch12.ads (Check_Private_View): Move around.
* sem_ch12.adb (Check_Private_View): Retrieve the partial view
by means of a call to Incomplete_Or_Partial_View.
(Save_Global_References.Set_Global_Type): Do not force the full
view of a type when only the partial declaration is visible.
* sem_res.adb (Resolve_Actuals.Insert_Default): Remove obsolete
code coping with the above kludge.
gcc/testsuite/
* gnat.dg/generic_inst21.adb: New test.
Diff:
---
gcc/ada/sem_ch12.adb | 30 +++++++------------
gcc/ada/sem_ch12.ads | 32 ++++++++++----------
gcc/ada/sem_res.adb | 17 -----------
gcc/testsuite/gnat.dg/generic_inst21.adb | 50 ++++++++++++++++++++++++++++++++
4 files changed, 77 insertions(+), 52 deletions(-)
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index c2697c74f969..2710d0545f45 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -9235,15 +9235,19 @@ package body Sem_Ch12 is
and then (not In_Open_Scopes (Scope (Typ))
or else Nkind (Parent (N)) = N_Subtype_Declaration)
then
+ -- In the generic unit, only the private declaration was visible,
+ -- so restore the partial view of Typ when there was an explicit
+ -- declaration of its full view.
+
declare
- Assoc : constant Node_Id := Get_Associated_Node (N);
+ Priv_Typ : constant Entity_Id :=
+ Incomplete_Or_Partial_View (Typ, Partial_Only => True);
begin
- -- In the generic, only the private declaration was visible
-
- Prepend_Elmt (Typ, Exchanged_Views);
- Exchange_Declarations
- (if Comparison then Compare_Type (Assoc) else Etype (Assoc));
+ if Present (Priv_Typ) then
+ Prepend_Elmt (Typ, Exchanged_Views);
+ Exchange_Declarations (Priv_Typ);
+ end if;
end;
-- Check that the available views of Typ match their respective flag.
@@ -18607,22 +18611,10 @@ package body Sem_Ch12 is
elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
null;
- -- Otherwise mark the type for flipping and set the full view on N2
- -- when available, which is necessary for Check_Private_View to swap
- -- back the views in case the full declaration of Typ is visible in
- -- the instantiation context. Note that this will be problematic if
- -- N2 is re-analyzed later, e.g. if it's a default value in a call.
+ -- Otherwise mark the node as seeing the private view
else
Set_Has_Private_View (N);
-
- if Present (Full_View (Typ)) then
- if Comparison then
- Set_Compare_Type (N2, Full_View (Typ));
- else
- Set_Etype (N2, Full_View (Typ));
- end if;
- end if;
end if;
if Is_Floating_Point_Type (Typ)
diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads
index 478d968ce952..94f6f9829b1f 100644
--- a/gcc/ada/sem_ch12.ads
+++ b/gcc/ada/sem_ch12.ads
@@ -64,6 +64,22 @@ package Sem_Ch12 is
-- this call, then Parent_Installed is set True, otherwise Parent_Installed
-- is unchanged by the call.
+ procedure Check_Private_View (N : Node_Id);
+ -- Check whether the type of a generic entity has a different view between
+ -- the point of generic analysis and the point of instantiation. If the
+ -- view has changed, then at the point of instantiation we restore the
+ -- correct view to perform semantic analysis of the instance, and reset
+ -- the current view after instantiation. The processing is driven by the
+ -- current private status of the type of the node, and Has_Private_View,
+ -- a flag that is set at the point of generic compilation. If view and
+ -- flag are inconsistent then the type is updated appropriately. A second
+ -- flag Has_Secondary_Private_View is used to update a second type related
+ -- to this type if need be.
+ --
+ -- This subprogram is used in Check_Generic_Actuals and Copy_Generic_Node,
+ -- and is exported here for the purpose of front-end inlining (see Exp_Ch6.
+ -- Expand_Inlined_Call.Process_Formals).
+
function Copy_Generic_Node
(N : Node_Id;
Parent_Id : Node_Id;
@@ -228,20 +244,4 @@ package Sem_Ch12 is
procedure Initialize;
-- Initializes internal data structures
- procedure Check_Private_View (N : Node_Id);
- -- Check whether the type of a generic entity has a different view between
- -- the point of generic analysis and the point of instantiation. If the
- -- view has changed, then at the point of instantiation we restore the
- -- correct view to perform semantic analysis of the instance, and reset
- -- the current view after instantiation. The processing is driven by the
- -- current private status of the type of the node, and Has_Private_View,
- -- a flag that is set at the point of generic compilation. If view and
- -- flag are inconsistent then the type is updated appropriately. A second
- -- flag Has_Secondary_Private_View is used to update a second type related
- -- to this type if need be.
- --
- -- This subprogram is used in Check_Generic_Actuals and Copy_Generic_Node,
- -- and is exported here for the purpose of front-end inlining (see Exp_Ch6.
- -- Expand_Inlined_Call.Process_Formals).
-
end Sem_Ch12;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 7f168499426f..53cef024b326 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4038,23 +4038,6 @@ package body Sem_Res is
and then Has_Discriminants (Etype (Actval))
then
Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
-
- -- Resolve entities with their own type, which may differ from
- -- the type of a reference in a generic context because of the
- -- trick used in Save_Global_References.Set_Global_Type to set
- -- full views forcefully, which did not anticipate the need to
- -- re-analyze default values in calls.
-
- elsif Is_Entity_Name (Actval) then
- Analyze_And_Resolve (Actval, Etype (Entity (Actval)));
-
- -- Ditto for calls whose name is an entity, for the same reason
-
- elsif Nkind (Actval) = N_Function_Call
- and then Is_Entity_Name (Name (Actval))
- then
- Analyze_And_Resolve (Actval, Etype (Entity (Name (Actval))));
-
else
Analyze_And_Resolve (Actval, Etype (Actval));
end if;
diff --git a/gcc/testsuite/gnat.dg/generic_inst21.adb b/gcc/testsuite/gnat.dg/generic_inst21.adb
new file mode 100644
index 000000000000..78ca5f0d9d64
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/generic_inst21.adb
@@ -0,0 +1,50 @@
+-- { dg-do compile }
+
+procedure Generic_Inst21 is
+
+ package Config is
+ type Config_Data is private;
+ private
+ type Config_Data is null record;
+ end Config;
+
+ generic
+ package Config_Saving is
+
+ type Config_Saver is synchronized interface;
+
+ procedure Register_For_Saving
+ (This : in out Config_Saver; Config_Data : Config.Config_Data)
+ is abstract;
+
+ type Instance is synchronized new Config_Saver with private;
+
+ private
+
+ protected type Instance is new Config_Saver with
+ overriding
+ procedure Register_For_Saving (Config_Data : Config.Config_Data);
+ end Instance;
+
+ end Config_Saving;
+
+ package body Config_Saving is
+
+ protected body Instance is
+ procedure Register_For_Saving (Config_Data : Config.Config_Data) is
+ begin
+ null;
+ end Register_For_Saving;
+ end Instance;
+
+ end Config_Saving;
+
+ package My_Config_Saving is new Config_Saving;
+
+ X : aliased My_Config_Saving.Instance;
+ Y : access My_Config_Saving.Config_Saver'Class := X'Access;
+ Z : Config.Config_Data;
+
+begin
+ Y.Register_For_Saving (Z);
+end;
More information about the Gcc-cvs
mailing list