From: Eric Botcazou Date: Tue, 4 Nov 2025 18:54:45 +0000 (+0100) Subject: Ada: Fix incorrect legality check in instantiation of child generic unit X-Git-Url: http://git.ipfire.org/gitweb.cgi?a=commitdiff_plain;h=8836210fb62058980aeb02d6aad7f6dbca87b50b;p=thirdparty%2Fgcc.git Ada: Fix incorrect legality check in instantiation of child generic unit 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. gcc/ada/ 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. gcc/testsuite/ * 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. --- diff --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); diff --git a/gcc/testsuite/gnat.dg/specs/generic_inst9.ads b/gcc/testsuite/gnat.dg/specs/generic_inst9.ads new file mode 100644 index 00000000000..d81d16b9667 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/generic_inst9.ads @@ -0,0 +1,20 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/specs/generic_inst9_pkg1.ads b/gcc/testsuite/gnat.dg/specs/generic_inst9_pkg1.ads new file mode 100644 index 00000000000..6c7b2a3efd3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/generic_inst9_pkg1.ads @@ -0,0 +1,5 @@ +generic + type T1 is private; +package Generic_Inst9_Pkg1 is + subtype T3 is T1; +end Generic_Inst9_Pkg1; diff --git a/gcc/testsuite/gnat.dg/specs/generic_inst9_pkg2-g.ads b/gcc/testsuite/gnat.dg/specs/generic_inst9_pkg2-g.ads new file mode 100644 index 00000000000..5118298d1e7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/generic_inst9_pkg2-g.ads @@ -0,0 +1,4 @@ +generic + type T2 is access the_pak1.T3; +package Generic_Inst9_Pkg2.G is +end Generic_Inst9_Pkg2.G; diff --git a/gcc/testsuite/gnat.dg/specs/generic_inst9_pkg2.ads b/gcc/testsuite/gnat.dg/specs/generic_inst9_pkg2.ads new file mode 100644 index 00000000000..53a9dee3b4e --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/generic_inst9_pkg2.ads @@ -0,0 +1,7 @@ +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;