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 <ebotca...@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.--- 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;
