Skip to content

R
riscv-gcc-1
Commit cffb8f95 by Ed Schonberg Committed by Pierre-Marie de Rodat
Options

[Ada] Legality rule on ancestors of type extensions in generic bodies 

This patch adds an RM reference for the rule that in a generic body a
type extension cannot have ancestors that are generic formal types. The
patch also extends the check to interface progenitors that may appear in
a derived type declaration or private extension declaration.

2019-08-13  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch3.adb (Check_Generic_Ancestor): New subprogram,
	aubsidiary to Build_Derived_Record_Type. to enforce the rule
	that a type extension declared in a generic body cznnot have an
	ancestor that is a generic formal (RM 3.9.1 (4/2)). The rule
	applies to all ancestors of the type, including interface
	progenitors.

gcc/testsuite/

	* gnat.dg/tagged4.adb: New testcase.

From-SVN: r274358
parent 7f078d5b
Showing with 122 additions and 46 deletions
gcc/ada/ChangeLog
2019-08-13 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Check_Generic_Ancestor): New subprogram,
aubsidiary to Build_Derived_Record_Type. to enforce the rule
that a type extension declared in a generic body cznnot have an
ancestor that is a generic formal (RM 3.9.1 (4/2)). The rule
applies to all ancestors of the type, including interface
progenitors.
2019-08-13 Eric Botcazou <ebotcazou@adacore.com>
* sem_ch3.adb (Build_Underlying_Full_View): Delete.
......
gcc/ada/sem_ch3.adb
......@@ -8574,6 +8574,84 @@ package body Sem_Ch3 is
-- An empty Discs list means that there were no constraints in the
-- subtype indication or that there was an error processing it.
procedure Check_Generic_Ancestors;
-- In Ada 2005 (AI-344), the restriction that a derived tagged type
-- cannot be declared at a deeper level than its parent type is
-- removed. The check on derivation within a generic body is also
-- relaxed, but there's a restriction that a derived tagged type
-- cannot be declared in a generic body if it's derived directly
-- or indirectly from a formal type of that generic. This applies
-- to progenitors as well.
-----------------------------
-- Check_Generic_Ancestors --
-----------------------------
procedure Check_Generic_Ancestors is
Ancestor_Type : Entity_Id;
Intf_List : List_Id;
Intf_Name : Node_Id;
procedure Check_Ancestor;
-- For parent and progenitors.
--------------------
-- Check_Ancestor --
--------------------
procedure Check_Ancestor is
begin
-- If the derived type does have a formal type as an ancestor
-- then it's an error if the derived type is declared within
-- the body of the generic unit that declares the formal type
-- in its generic formal part. It's sufficient to check whether
-- the ancestor type is declared inside the same generic body
-- as the derived type (such as within a nested generic spec),
-- in which case the derivation is legal. If the formal type is
-- declared outside of that generic body, then it's certain
-- that the derived type is declared within the generic body
-- of the generic unit declaring the formal type.
if Is_Generic_Type (Ancestor_Type)
and then Enclosing_Generic_Body (Ancestor_Type) /=
Enclosing_Generic_Body (Derived_Type)
then
Error_Msg_NE
("ancestor type& is formal type of enclosing"
& " generic unit (RM 3.9.1 (4/2))",
Indic, Ancestor_Type);
end if;
end Check_Ancestor;
begin
if Nkind (N) = N_Private_Extension_Declaration then
Intf_List := Interface_List (N);
else
Intf_List := Interface_List (Type_Definition (N));
end if;
if Present (Enclosing_Generic_Body (Derived_Type)) then
Ancestor_Type := Parent_Type;
while not Is_Generic_Type (Ancestor_Type)
and then Etype (Ancestor_Type) /= Ancestor_Type
loop
Ancestor_Type := Etype (Ancestor_Type);
end loop;
Check_Ancestor;
if Present (Intf_List) then
Intf_Name := First (Intf_List);
while Present (Intf_Name) loop
Ancestor_Type := Entity (Intf_Name);
Check_Ancestor;
Next (Intf_Name);
end loop;
end if;
end if;
end Check_Generic_Ancestors;
begin
if Ekind (Parent_Type) = E_Record_Type_With_Private
and then Present (Full_View (Parent_Type))
......@@ -8680,7 +8758,8 @@ package body Sem_Ch3 is
-- Indic can either be an N_Identifier if the subtype indication
-- contains no constraint or an N_Subtype_Indication if the subtype
-- indication has a constraint.
-- indecation has a constraint. In either case it can include an
-- interface list.
Indic := Subtype_Indication (Type_Def);
Constraint_Present := (Nkind (Indic) = N_Subtype_Indication);
......@@ -8909,52 +8988,8 @@ package body Sem_Ch3 is
Freeze_Before (N, Parent_Type);
end if;
-- In Ada 2005 (AI-344), the restriction that a derived tagged type
-- cannot be declared at a deeper level than its parent type is
-- removed. The check on derivation within a generic body is also
-- relaxed, but there's a restriction that a derived tagged type
-- cannot be declared in a generic body if it's derived directly
-- or indirectly from a formal type of that generic.
if Ada_Version >= Ada_2005 then
if Present (Enclosing_Generic_Body (Derived_Type)) then
declare
Ancestor_Type : Entity_Id;
begin
-- Check to see if any ancestor of the derived type is a
-- formal type.
Ancestor_Type := Parent_Type;
while not Is_Generic_Type (Ancestor_Type)
and then Etype (Ancestor_Type) /= Ancestor_Type
loop
Ancestor_Type := Etype (Ancestor_Type);
end loop;
-- If the derived type does have a formal type as an
-- ancestor, then it's an error if the derived type is
-- declared within the body of the generic unit that
-- declares the formal type in its generic formal part. It's
-- sufficient to check whether the ancestor type is declared
-- inside the same generic body as the derived type (such as
-- within a nested generic spec), in which case the
-- derivation is legal. If the formal type is declared
-- outside of that generic body, then it's guaranteed that
-- the derived type is declared within the generic body of
-- the generic unit declaring the formal type.
if Is_Generic_Type (Ancestor_Type)
and then Enclosing_Generic_Body (Ancestor_Type) /=
Enclosing_Generic_Body (Derived_Type)
then
Error_Msg_NE
("parent type of& must not be descendant of formal type"
& " of an enclosing generic body",
Indic, Derived_Type);
end if;
end;
end if;
Check_Generic_Ancestors;
elsif Type_Access_Level (Derived_Type) /=
Type_Access_Level (Parent_Type)
......
gcc/testsuite/ChangeLog
2019-08-13 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/tagged4.adb: New testcase.
2019-08-13 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/generic_inst10.adb, gnat.dg/generic_inst10_pkg.ads:
......
gcc/testsuite/gnat.dg/tagged4.adb 0 → 100644
-- { dg-do compile }
procedure Tagged4 is
type T0 is tagged null record;
generic
type F1 is tagged private;
procedure Gen1;
procedure Gen1 is
type Inst1 is new F1 with null record; -- { dg-error "ancestor type \"F1\" is formal type of enclosing generic unit \\(RM 3\\.9\\.1 \\(4\\/2\\)\\)" }
begin
null;
end Gen1;
generic
type F2 is interface;
procedure Gen2;
procedure Gen2 is
type Inst2 is new T0 and F2 with null record; -- { dg-error "ancestor type \"F2\" is formal type of enclosing generic unit \\(RM 3\\.9\\.1 \\(4\\/2\\)\\)" }
begin
null;
end Gen2;
begin
null;
end Tagged4;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment