From: Eric Botcazou Date: Tue, 13 Aug 2019 08:08:47 +0000 (+0000) Subject: [Ada] Build full derivation for private concurrent type X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ed5786a74537bde38eba66b44fa0aa88b3d2ae89;p=gcc.git [Ada] Build full derivation for private concurrent type This extends the processing done for the derivation of private discriminated types to concurrent types, which is now required because this derivation is no longer redone when a subtype of the derived concurrent type is built. This increases the number of entities generated internally in the compiler but this case is sufficiently rare as not to be a real concern. 2019-08-13 Eric Botcazou gcc/ada/ * sem_ch3.adb (Build_Derived_Concurrent_Type): Add a couple of local variables and use them. When the derived type fully constrains the parent type, rewrite it as a subtype of an implicit (unconstrained) derived type instead of the other way around. (Copy_And_Build): Deal with concurrent types and use predicates. (Build_Derived_Private_Type): Build the full derivation if needed for concurrent types too. (Build_Derived_Record_Type): Add marker comment. (Complete_Private_Subtype): Use predicates. gcc/testsuite/ * gnat.dg/discr56.adb, gnat.dg/discr56.ads, gnat.dg/discr56_pkg1.adb, gnat.dg/discr56_pkg1.ads, gnat.dg/discr56_pkg2.ads: New testcase. From-SVN: r274359 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9ea478d1c98..c0c6c53140d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2019-08-13 Eric Botcazou + + * sem_ch3.adb (Build_Derived_Concurrent_Type): Add a couple of + local variables and use them. When the derived type fully + constrains the parent type, rewrite it as a subtype of an + implicit (unconstrained) derived type instead of the other way + around. + (Copy_And_Build): Deal with concurrent types and use predicates. + (Build_Derived_Private_Type): Build the full derivation if + needed for concurrent types too. + (Build_Derived_Record_Type): Add marker comment. + (Complete_Private_Subtype): Use predicates. + 2019-08-13 Ed Schonberg * sem_ch3.adb (Check_Generic_Ancestor): New subprogram, diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index c5655ee8480..218aa0c9e07 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6831,7 +6831,9 @@ package body Sem_Ch3 is Parent_Type : Entity_Id; Derived_Type : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); + Def : constant Node_Id := Type_Definition (N); + Indic : constant Node_Id := Subtype_Indication (Def); Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C'); Corr_Decl : Node_Id; @@ -6842,8 +6844,7 @@ package body Sem_Ch3 is -- this case. Constraint_Present : constant Boolean := - Nkind (Subtype_Indication (Type_Definition (N))) = - N_Subtype_Indication; + Nkind (Indic) = N_Subtype_Indication; D_Constraint : Node_Id; New_Constraint : Elist_Id := No_Elist; @@ -6918,36 +6919,50 @@ package body Sem_Ch3 is Expand_To_Stored_Constraint (Parent_Type, Build_Discriminant_Constraints - (Parent_Type, - Subtype_Indication (Type_Definition (N)), True)); + (Parent_Type, Indic, True)); end if; End_Scope; elsif Constraint_Present then - -- Build constrained subtype, copying the constraint, and derive - -- from it to create a derived constrained type. + -- Build an unconstrained derived type and rewrite the derived type + -- as a subtype of this new base type. declare - Loc : constant Source_Ptr := Sloc (N); - Anon : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Derived_Type), 'T')); - Decl : Node_Id; + Parent_Base : constant Entity_Id := Base_Type (Parent_Type); + New_Base : Entity_Id; + New_Decl : Node_Id; + New_Indic : Node_Id; begin - Decl := + New_Base := + Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B'); + + New_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => New_Base, + Type_Definition => + Make_Derived_Type_Definition (Loc, + Abstract_Present => Abstract_Present (Def), + Limited_Present => Limited_Present (Def), + Subtype_Indication => + New_Occurrence_Of (Parent_Base, Loc))); + + Mark_Rewrite_Insertion (New_Decl); + Insert_Before (N, New_Decl); + Analyze (New_Decl); + + New_Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (New_Base, Loc), + Constraint => Relocate_Node (Constraint (Indic))); + + Rewrite (N, Make_Subtype_Declaration (Loc, - Defining_Identifier => Anon, - Subtype_Indication => - New_Copy_Tree (Subtype_Indication (Type_Definition (N)))); - Insert_Before (N, Decl); - Analyze (Decl); + Defining_Identifier => Derived_Type, + Subtype_Indication => New_Indic)); - Rewrite (Subtype_Indication (Type_Definition (N)), - New_Occurrence_Of (Anon, Loc)); - Set_Analyzed (Derived_Type, False); Analyze (N); return; end; @@ -6978,10 +6993,7 @@ package body Sem_Ch3 is -- Verify that new discriminants are used to constrain old ones - D_Constraint := - First - (Constraints - (Constraint (Subtype_Indication (Type_Definition (N))))); + D_Constraint := First (Constraints (Constraint (Indic))); Old_Disc := First_Discriminant (Parent_Type); @@ -7662,14 +7674,15 @@ package body Sem_Ch3 is Full_Parent := Underlying_Full_View (Full_Parent); end if; - -- For record, access and most enumeration types, derivation from - -- the full view requires a fully-fledged declaration. In the other - -- cases, just use an itype. + -- For record, concurrent, access and most enumeration types, the + -- derivation from full view requires a fully-fledged declaration. + -- In the other cases, just use an itype. - if Ekind (Full_Parent) in Record_Kind - or else Ekind (Full_Parent) in Access_Kind + if Is_Record_Type (Full_Parent) + or else Is_Concurrent_Type (Full_Parent) + or else Is_Access_Type (Full_Parent) or else - (Ekind (Full_Parent) in Enumeration_Kind + (Is_Enumeration_Type (Full_Parent) and then not Is_Standard_Character_Type (Full_Parent) and then not Is_Generic_Type (Root_Type (Full_Parent))) then @@ -7698,7 +7711,7 @@ package body Sem_Ch3 is -- is now installed. Subprograms have been derived on the partial -- view, the completion does not derive them anew. - if Ekind (Full_Parent) in Record_Kind then + if Is_Record_Type (Full_Parent) then -- If parent type is tagged, the completion inherits the proper -- primitive operations. @@ -7900,12 +7913,10 @@ package body Sem_Ch3 is -- Build the full derivation if this is not the anonymous derived -- base type created by Build_Derived_Record_Type in the constrained -- case (see point 5. of its head comment) since we build it for the - -- derived subtype. And skip it for synchronized types altogether, as - -- gigi does not use these types directly. + -- derived subtype. if Present (Full_View (Parent_Type)) and then not Is_Itype (Derived_Type) - and then not Is_Concurrent_Type (Full_View (Parent_Type)) then declare Der_Base : constant Entity_Id := Base_Type (Derived_Type); @@ -8652,6 +8663,8 @@ package body Sem_Ch3 is end if; end Check_Generic_Ancestors; + -- Start of processing for Build_Derived_Record_Type + begin if Ekind (Parent_Type) = E_Record_Type_With_Private and then Present (Full_View (Parent_Type)) @@ -12265,10 +12278,9 @@ package body Sem_Ch3 is Save_Next_Entity := Next_Entity (Full); Save_Homonym := Homonym (Priv); - if Ekind (Full_Base) in Private_Kind - or else Ekind (Full_Base) in Protected_Kind - or else Ekind (Full_Base) in Record_Kind - or else Ekind (Full_Base) in Task_Kind + if Is_Private_Type (Full_Base) + or else Is_Record_Type (Full_Base) + or else Is_Concurrent_Type (Full_Base) then Copy_Node (Priv, Full); @@ -12411,7 +12423,7 @@ package body Sem_Ch3 is -- If the full base is itself derived from private, build a congruent -- subtype of its underlying full view, for use by the back end. - elsif Ekind (Full_Base) in Private_Kind + elsif Is_Private_Type (Full_Base) and then Present (Underlying_Full_View (Full_Base)) then declare diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2960f5b40af..5b8ed3aaf7c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2019-08-13 Eric Botcazou + + * gnat.dg/discr56.adb, gnat.dg/discr56.ads, + gnat.dg/discr56_pkg1.adb, gnat.dg/discr56_pkg1.ads, + gnat.dg/discr56_pkg2.ads: New testcase. + 2019-08-13 Ed Schonberg * gnat.dg/tagged4.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/discr56.adb b/gcc/testsuite/gnat.dg/discr56.adb new file mode 100644 index 00000000000..dc0ca7f57fa --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr56.adb @@ -0,0 +1,5 @@ +-- { dg-do compile } + +package body Discr56 is + procedure Dummy is null; +end Discr56; diff --git a/gcc/testsuite/gnat.dg/discr56.ads b/gcc/testsuite/gnat.dg/discr56.ads new file mode 100644 index 00000000000..443f1bdd314 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr56.ads @@ -0,0 +1,9 @@ +with Discr56_Pkg2; + +package Discr56 is + + Obj : Discr56_Pkg2.Buffer (1); + + procedure Dummy; + +end Discr56; diff --git a/gcc/testsuite/gnat.dg/discr56_pkg1.adb b/gcc/testsuite/gnat.dg/discr56_pkg1.adb new file mode 100644 index 00000000000..67c329ab756 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr56_pkg1.adb @@ -0,0 +1,6 @@ +package body Discr56_Pkg1 is + + protected body Buffer is + end Buffer; + +end Discr56_Pkg1; diff --git a/gcc/testsuite/gnat.dg/discr56_pkg1.ads b/gcc/testsuite/gnat.dg/discr56_pkg1.ads new file mode 100644 index 00000000000..38526326336 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr56_pkg1.ads @@ -0,0 +1,14 @@ +package Discr56_Pkg1 is + + type Buffer (Size : Positive) is limited private; + +private + + type Arr is array (Natural range <>) of Integer; + + protected type Buffer (Size : Positive) is + private + Store : Arr (0..Size); + end Buffer; + +end Discr56_Pkg1; diff --git a/gcc/testsuite/gnat.dg/discr56_pkg2.ads b/gcc/testsuite/gnat.dg/discr56_pkg2.ads new file mode 100644 index 00000000000..dc94908bb75 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr56_pkg2.ads @@ -0,0 +1,11 @@ +with Discr56_Pkg1; + +package Discr56_Pkg2 is + + type Buffer (Size : Positive) is limited private; + +private + + type Buffer (Size : Positive) is new Discr56_Pkg1.Buffer (Size); + +end Discr56_Pkg2;