[COMMITTED] ada: Illegal instance of Generic_1.Generic_2 incorrectly accepted
Checks
Commit Message
From: Steve Baird <baird@adacore.com>
If G1 is a generic package and G1.G2 is a child unit (also a generic package)
then it would be illegal if some third generic unit (declared outside of G1)
takes a formal instance of G1.G2, as in "with package I2 is new G1.G2;".
This construct was incorrectly accepted in some cases.
gcc/ada/
* sem_ch12.adb (Check_Generic_Child_Unit): Introduce a new nested
function Adjusted_Inst_Par_Ekind to cope with cases where either
a- the visibility of a compiler-generated renaming is incorrect;
or b- we are inside of a generic parent unit G1 that has a child
unit G1.G2, so instantiation of G1.G2 is permitted.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_ch12.adb | 96 +++++++++++++++++++++++++++++++++++++++-----
1 file changed, 85 insertions(+), 11 deletions(-)
@@ -7234,7 +7234,7 @@ package body Sem_Ch12 is
Loc : constant Source_Ptr := Sloc (Gen_Id);
Gen_Par : Entity_Id := Empty;
E : Entity_Id;
- Inst_Par : Entity_Id;
+ Inst_Par : Entity_Id := Empty;
S : Node_Id;
function Find_Generic_Child
@@ -7440,16 +7440,90 @@ package body Sem_Ch12 is
-- the instance of Gpar, so this is illegal. The test below
-- recognizes this particular case.
- if Is_Child_Unit (E)
- and then not Comes_From_Source (Entity (Prefix (Gen_Id)))
- and then (not In_Instance
- or else Nkind (Parent (Parent (Gen_Id))) =
- N_Compilation_Unit)
- then
- Error_Msg_N
- ("prefix of generic child unit must be instance of parent",
- Gen_Id);
- end if;
+ declare
+ -- We want to reject the final instantiation in
+ -- generic package G1 is end G1;
+ -- generic package G1.G2 is end G1.G2;
+ -- with G1; package I1 is new G1;
+ -- with G1.G2; package I1.I2 is new G1.G2;
+ -- because the use of G1.G2 should instead be either
+ -- I1.G2 or simply G2. However, the tree that is built
+ -- in this case is wrong. In the expanded copy
+ -- of G2, we need (and therefore generate) a renaming
+ -- package G1 renames I1;
+ -- but this renaming should not participate in resolving
+ -- this occurrence of the name "G1.G2"; unfortunately,
+ -- it does. Rather than correct this error, we compensate
+ -- for it in this function.
+ --
+ -- We also perform another adjustment here. If we are
+ -- currently inside a generic package, then that
+ -- generic package needs to be treated as a package.
+ -- For example, if a generic Aaa declares a nested generic
+ -- Bbb (perhaps as a child unit) then Aaa can also legally
+ -- declare an instance of Aaa.Bbb.
+
+ function Adjusted_Inst_Par_Ekind return Entity_Kind;
+
+ -----------------------------
+ -- Adjusted_Inst_Par_Ekind --
+ -----------------------------
+
+ function Adjusted_Inst_Par_Ekind return Entity_Kind is
+ Prefix_Entity : Entity_Id;
+ Inst_Par_GP : Node_Id;
+ Inst_Par_Parent : Node_Id := Parent (Inst_Par);
+ begin
+ if Nkind (Inst_Par_Parent) = N_Defining_Program_Unit_Name
+ then
+ Inst_Par_Parent := Parent (Inst_Par_Parent);
+ end if;
+
+ Inst_Par_GP := Generic_Parent (Inst_Par_Parent);
+
+ if Nkind (Gen_Id) = N_Expanded_Name
+ and then Present (Inst_Par_GP)
+ and then Ekind (Inst_Par_GP) = E_Generic_Package
+ then
+ Prefix_Entity := Entity (Prefix (Gen_Id));
+
+ if Present (Prefix_Entity)
+ and then not Comes_From_Source (Prefix_Entity)
+ and then Nkind (Parent (Prefix_Entity)) =
+ N_Package_Renaming_Declaration
+ and then Chars (Prefix_Entity) = Chars (Inst_Par_GP)
+ then
+ return E_Generic_Package;
+ end if;
+ end if;
+
+ if Ekind (Inst_Par) = E_Generic_Package
+ and then In_Open_Scopes (Inst_Par)
+ then
+ -- If we are inside a generic package then
+ -- treat it as a package.
+ return E_Package;
+ end if;
+
+ -- The usual path
+ return Ekind (Inst_Par);
+ end Adjusted_Inst_Par_Ekind;
+
+ begin
+ if Is_Child_Unit (E)
+ and then (No (Inst_Par)
+ or else Adjusted_Inst_Par_Ekind =
+ E_Generic_Package)
+ and then (not In_Instance
+ or else Nkind (Parent (Parent (Gen_Id))) =
+ N_Compilation_Unit)
+ then
+ Error_Msg_N
+ ("prefix of generic child unit must be " &
+ "instance of parent",
+ Gen_Id);
+ end if;
+ end;
if not In_Open_Scopes (Inst_Par)
and then Nkind (Parent (Gen_Id)) not in