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.
Tested on x86-64/Linux, applied on the mainline.
2026-03-27 Eric Botcazou <[email protected]>
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.
2026-03-27 Eric Botcazou <[email protected]>
* gnat.dg/generic_inst21.adb: New test.
--
Eric Botcazoudiff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index c2697c74f96..2710d0545f4 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 478d968ce95..94f6f9829b1 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 7f168499426..53cef024b32 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;
-- { 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;
