[Ada] Build full derivation for private concurrent type
diff mbox series

Message ID 20190813083158.GA38724@adacore.com
State New
Headers show
Series
  • [Ada] Build full derivation for private concurrent type
Related show

Commit Message

Pierre-Marie de Rodat Aug. 13, 2019, 8:31 a.m. UTC
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.

Tested on x86_64-pc-linux-gnu, committed on trunk

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.

Patch
diff mbox series

--- gcc/ada/sem_ch3.adb
+++ 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

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/discr56.adb
@@ -0,0 +1,5 @@ 
+--  { dg-do compile }
+
+package body Discr56 is
+  procedure Dummy is null;
+end Discr56;

--- /dev/null
new file mode 100644
+++ 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;

--- /dev/null
new file mode 100644
+++ 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;

--- /dev/null
new file mode 100644
+++ 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;

--- /dev/null
new file mode 100644
+++ 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;