[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  <ebotcazou@adacore.com>

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 9ea478d1c985a94a29bbd2814b35806e6d0c79b6..c0c6c53140dd425dd32737d3a9b0051adb5d63d3 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2019-08-13  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * 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  <schonberg@adacore.com>
 
        * sem_ch3.adb (Check_Generic_Ancestor): New subprogram,

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index c5655ee84802f05ff2fb50b2d956338d41095ab2..218aa0c9e07f57343c864bceae7a04ca6ec75a14 100644 (file)
--- 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 2960f5b40afc58cba31989bc6b10cad5c907dfa2..5b8ed3aaf7ca2ea463e017a387515bef731de1a8 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2019-08-13  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * 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  <schonberg@adacore.com>
 
        * 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 (file)
index 0000000..dc0ca7f
--- /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 (file)
index 0000000..443f1bd
--- /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 (file)
index 0000000..67c329a
--- /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 (file)
index 0000000..3852632
--- /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 (file)
index 0000000..dc94908
--- /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;