The problem arises when the generic unit has a formal access type parameter,
because the manual resolution implemented in Find_Actual_Type does not pick
the correct entity for the designated type. The fix replaces it with a bona
fide resolution and cleans up the associated code in the callers.
Tested on x86-64/Linux, applied on the mainline.
2025-11-04 Eric Botcazou <[email protected]>
PR ada/18453
* sem_ch12.adb (Find_Actual_Type): Add Typ_Ref parameter and
perform a standard resolution on it in the fallback case.
Call Get_Instance_Of if the type is declared in a formal of
the child unit.
(Instantiate_Type.Validate_Access_Type_Instance): Adjust call
to Find_Actual_Type.
(Instantiate_Type.Validate_Array_Type_Instance): Likewise and
streamline the check for matching component subtypes.
2025-11-04 Eric Botcazou <[email protected]>
* gnat.dg/specs/generic_inst9.ads: New test.
* gnat.dg/specs/generic_inst9_pkg1.ads: New helper.
* gnat.dg/specs/generic_inst9_pkg2.ads: Likewise.
* gnat.dg/specs/generic_inst9_pkg2-g.ads: Likewise.
--
Eric Botcazoudiff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 363abe38d0d..b6f5ed0dad4 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -642,8 +642,9 @@ package body Sem_Ch12 is
-- of freeze nodes for instance bodies that may depend on other instances.
function Find_Actual_Type
- (Typ : Entity_Id;
- Gen_Type : Entity_Id) return Entity_Id;
+ (Typ : Entity_Id;
+ Gen_Type : Entity_Id;
+ Typ_Ref : Node_Id) return Entity_Id;
-- When validating the actual types of a child instance, check whether
-- the formal is a formal type of the parent unit, and retrieve the current
-- actual for it. Typ is the entity in the analyzed formal type declaration
@@ -653,7 +654,8 @@ package body Sem_Ch12 is
-- be declared in a formal package of a parent. In both cases it is a
-- generic actual type because it appears within a visible instance.
-- Finally, it may be declared in a parent unit without being a formal
- -- of that unit, in which case it must be retrieved by visibility.
+ -- of that unit, in which case it must be retrieved by visibility and
+ -- Typ_Ref is the unanalyzed subtype mark in the instance to be used.
-- Ambiguities may still arise if two homonyms are declared in two formal
-- packages, and the prefix of the formal type may be needed to resolve
-- the ambiguity in the instance ???
@@ -10465,10 +10467,10 @@ package body Sem_Ch12 is
function Find_Actual_Type
(Typ : Entity_Id;
- Gen_Type : Entity_Id) return Entity_Id
+ Gen_Type : Entity_Id;
+ Typ_Ref : Node_Id) return Entity_Id
is
Gen_Scope : constant Entity_Id := Scope (Gen_Type);
- T : Entity_Id;
begin
-- Special processing only applies to child units
@@ -10482,6 +10484,12 @@ package body Sem_Ch12 is
elsif Scope (Typ) = Gen_Scope then
return Get_Instance_Of (Typ);
+ -- If designated or component type is declared in a formal of the child
+ -- unit, its instance is available.
+
+ elsif Scope (Scope (Typ)) = Gen_Scope then
+ return Get_Instance_Of (Typ);
+
-- If the array or access type is not declared in the parent unit,
-- no special processing needed.
@@ -10493,18 +10501,8 @@ package body Sem_Ch12 is
-- Otherwise, retrieve designated or component type by visibility
else
- T := Current_Entity (Typ);
- while Present (T) loop
- if In_Open_Scopes (Scope (T)) then
- return T;
- elsif Is_Generic_Actual_Type (T) then
- return T;
- end if;
-
- T := Homonym (T);
- end loop;
-
- return Typ;
+ Analyze (Typ_Ref);
+ return Entity (Typ_Ref);
end if;
end Find_Actual_Type;
@@ -14596,7 +14594,8 @@ package body Sem_Ch12 is
procedure Validate_Access_Type_Instance is
Desig_Type : constant Entity_Id :=
- Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T);
+ Find_Actual_Type
+ (Designated_Type (A_Gen_T), A_Gen_T, Subtype_Indication (Def));
Desig_Act : Entity_Id;
begin
@@ -14685,31 +14684,15 @@ package body Sem_Ch12 is
----------------------------------
procedure Validate_Array_Type_Instance is
- I1 : Node_Id;
- I2 : Node_Id;
- T2 : Entity_Id;
-
- function Formal_Dimensions return Nat;
- -- Count number of dimensions in array type formal
+ Dims : constant List_Id
+ := (if Nkind (Def) = N_Constrained_Array_Definition
+ then Discrete_Subtype_Definitions (Def)
+ else Subtype_Marks (Def));
- -----------------------
- -- Formal_Dimensions --
- -----------------------
-
- function Formal_Dimensions return Nat is
- Dims : List_Id;
-
- begin
- if Nkind (Def) = N_Constrained_Array_Definition then
- Dims := Discrete_Subtype_Definitions (Def);
- else
- Dims := Subtype_Marks (Def);
- end if;
-
- return List_Length (Dims);
- end Formal_Dimensions;
-
- -- Start of processing for Validate_Array_Type_Instance
+ Dim : Node_Id;
+ I1 : Node_Id;
+ I2 : Node_Id;
+ T2 : Entity_Id;
begin
if not Is_Array_Type (Act_T) then
@@ -14734,15 +14717,16 @@ package body Sem_Ch12 is
end if;
end if;
- if Formal_Dimensions /= Number_Dimensions (Act_T) then
+ if List_Length (Dims) /= Number_Dimensions (Act_T) then
Error_Msg_NE
("dimensions of actual do not match formal &", Actual, Gen_T);
Abandon_Instantiation (Actual);
end if;
- I1 := First_Index (A_Gen_T);
- I2 := First_Index (Act_T);
- for J in 1 .. Formal_Dimensions loop
+ Dim := First (Dims);
+ I1 := First_Index (A_Gen_T);
+ I2 := First_Index (Act_T);
+ for J in 1 .. List_Length (Dims) loop
-- If the indexes of the actual were given by a subtype_mark,
-- the index was transformed into a range attribute. Retrieve
@@ -14765,7 +14749,13 @@ package body Sem_Ch12 is
end if;
if not Subtypes_Match
- (Find_Actual_Type (Etype (I1), A_Gen_T), T2)
+ (Find_Actual_Type
+ (Etype (I1),
+ A_Gen_T,
+ (if Nkind (Dim) = N_Subtype_Indication
+ then Subtype_Mark (Dim)
+ else Dim)),
+ T2)
then
Error_Msg_NE
("index types of actual do not match those of formal &",
@@ -14773,34 +14763,20 @@ package body Sem_Ch12 is
Abandon_Instantiation (Actual);
end if;
+ Next (Dim);
Next_Index (I1);
Next_Index (I2);
end loop;
- -- Check matching subtypes. Note that there are complex visibility
- -- issues when the generic is a child unit and some aspect of the
- -- generic type is declared in a parent unit of the generic. We do
- -- the test to handle this special case only after a direct check
- -- for static matching has failed. The case where both the component
- -- type and the array type are separate formals, and the component
- -- type is a private view may also require special checking in
- -- Subtypes_Match. Finally, we assume that a child instance where
- -- the component type comes from a formal of a parent instance is
- -- correct because the generic was correct. A more precise check
- -- seems too complex to install???
-
- if Subtypes_Match
- (Component_Type (A_Gen_T), Component_Type (Act_T))
- or else
- Subtypes_Match
- (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T),
- Component_Type (Act_T))
- or else
- (not Inside_A_Generic
- and then Is_Child_Unit (Scope (Component_Type (A_Gen_T))))
+ -- Check matching component subtypes
+
+ if not Subtypes_Match
+ (Find_Actual_Type
+ (Component_Type (A_Gen_T),
+ A_Gen_T,
+ Subtype_Indication (Component_Definition (Def))),
+ Component_Type (Act_T))
then
- null;
- else
Error_Msg_NE
("component subtype of actual does not match that of formal &",
Actual, Gen_T);
-- { dg-do compile }
with Generic_Inst9_Pkg1;
with Generic_Inst9_Pkg2.G;
package Generic_Inst9 is
type T4 is null record;
type T5 is null record;
subtype T3 is T5;
type T4_ptr is access T4;
type T5_ptr is access T5;
package My_Pkg2 is new Generic_Inst9_Pkg2 (T2 => T4);
package My_G4 is new My_Pkg2.G (T4_ptr); -- { dg-bogus "does not match|abandoned" }
package My_G5 is new My_Pkg2.G (T5_ptr); -- { dg-error "does not match|abandoned" }
end Generic_Inst9;
generic
type T1 is private;
package Generic_Inst9_Pkg1 is
subtype T3 is T1;
end Generic_Inst9_Pkg1;
generic
type T2 is access the_pak1.T3;
package Generic_Inst9_Pkg2.G is
end Generic_Inst9_Pkg2.G;
with Generic_Inst9_Pkg1;
generic
type T2 is private;
package Generic_Inst9_Pkg2 is
package the_pak1 is new Generic_Inst9_Pkg1 (T1 => T2);
end Generic_Inst9_Pkg2;
