From: Ed Schonberg Date: Tue, 13 Aug 2019 08:08:40 +0000 (+0000) Subject: [Ada] Legality rule on ancestors of type extensions in generic bodies X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=cffb8f959c237b5af9e94ad4d0188a34acf5d910;p=gcc.git [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 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index dc039a6d919..9ea478d1c98 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2019-08-13 Ed Schonberg + + * 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 * sem_ch3.adb (Build_Underlying_Full_View): Delete. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ae8600c9803..c5655ee8480 100644 --- a/gcc/ada/sem_ch3.adb +++ b/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) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f3882db65fb..2960f5b40af 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-08-13 Ed Schonberg + + * gnat.dg/tagged4.adb: New testcase. + 2019-08-13 Eric Botcazou * gnat.dg/generic_inst10.adb, gnat.dg/generic_inst10_pkg.ads: diff --git a/gcc/testsuite/gnat.dg/tagged4.adb b/gcc/testsuite/gnat.dg/tagged4.adb new file mode 100644 index 00000000000..7611b9e9d13 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tagged4.adb @@ -0,0 +1,28 @@ +-- { 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;