[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
This commit is contained in:
Eric Botcazou
Pierre-Marie de Rodat
parent
cffb8f959c
commit
ed5786a745
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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 :=
|
||||
Make_Subtype_Declaration (Loc,
|
||||
Defining_Identifier => Anon,
|
||||
Subtype_Indication =>
|
||||
New_Copy_Tree (Subtype_Indication (Type_Definition (N))));
|
||||
Insert_Before (N, Decl);
|
||||
Analyze (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 => 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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
-- { dg-do compile }
|
||||
|
||||
package body Discr56 is
|
||||
procedure Dummy is null;
|
||||
end Discr56;
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
with Discr56_Pkg2;
|
||||
|
||||
package Discr56 is
|
||||
|
||||
Obj : Discr56_Pkg2.Buffer (1);
|
||||
|
||||
procedure Dummy;
|
||||
|
||||
end Discr56;
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
package body Discr56_Pkg1 is
|
||||
|
||||
protected body Buffer is
|
||||
end Buffer;
|
||||
|
||||
end Discr56_Pkg1;
|
||||
|
|
@ -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;
|
||||
|
|
@ -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;
|
||||
Loading…
Reference in New Issue