MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Alignment clause ignored on completion derived from private type

Browse Source 
2020-06-04  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* exp_attr.adb (xpand_N_Attribute_Reference) <Input>: Call
	Find_Inherited_TSS to look up the Stream_Read TSS.
	<Output>: Likewise for the Stream_Write TSS.
	* exp_ch7.adb (Make_Final_Call): Call Underlying_Type on
	private types to account for underlying full views.
	* exp_strm.ads  (Build_Record_Or_Elementary_Input_Function):
	Remove Use_Underlying parameter.
	* exp_strm.adb (Build_Record_Or_Elementary_Input_Function):
	Likewise and adjust accordingly.
	* exp_tss.adb (Find_Inherited_TSS): Deal with full views.
	Call Find_Inherited_TSS recursively on the parent type if
	the base type is a derived type.
	* sem_ch13.adb (Analyze_Attribute_Definition_Clause): Take
	into account underlying full views for derived types.
	* sem_ch3.adb (Copy_And_Build): Look up the underlying full
	view only for a completion.  Be prepared for private types.
	(Build_Derived_Private_Type): Build an underlying full view
	for a completion in the general case too.
This commit is contained in:
Eric Botcazou 2020-01-27 12:50:23 +01:00 committed by Pierre-Marie de Rodat
parent e5e53c73a0
commit a3fbeceef4
7 changed files with 71 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
gcc/ada/exp_attr.adb
View File

@ -3879,26 +3879,18 @@ package body Exp_Attr is
-- A special case arises if we have a defined _Read routine,
-- since in this case we are required to call this routine.
declare
Typ : Entity_Id := P_Type;
begin
if Present (Full_View (Typ)) then
Typ := Full_View (Typ);
end if;
if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Read)) then
Build_Record_Or_Elementary_Input_Function
(Loc, P_Type, Decl, Fname);
Insert_Action (N, Decl);
if Present (TSS (Base_Type (Typ), TSS_Stream_Read)) then
Build_Record_Or_Elementary_Input_Function
(Loc, Typ, Decl, Fname, Use_Underlying => False);
Insert_Action (N, Decl);
-- For normal cases, we call the I_xxx routine directly
-- For normal cases, we call the I_xxx routine directly
else
Rewrite (N, Build_Elementary_Input_Call (N));
Analyze_And_Resolve (N, P_Type);
return;
end if;
end;
else
Rewrite (N, Build_Elementary_Input_Call (N));
Analyze_And_Resolve (N, P_Type);
return;
end if;
-- Array type case
@ -4985,26 +4977,18 @@ package body Exp_Attr is
-- A special case arises if we have a defined _Write routine,
-- since in this case we are required to call this routine.
declare
Typ : Entity_Id := P_Type;
begin
if Present (Full_View (Typ)) then
Typ := Full_View (Typ);
end if;
if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Write)) then
Build_Record_Or_Elementary_Output_Procedure
(Loc, P_Type, Decl, Pname);
Insert_Action (N, Decl);
if Present (TSS (Base_Type (Typ), TSS_Stream_Write)) then
Build_Record_Or_Elementary_Output_Procedure
(Loc, Typ, Decl, Pname);
Insert_Action (N, Decl);
-- For normal cases, we call the W_xxx routine directly
-- For normal cases, we call the W_xxx routine directly
else
Rewrite (N, Build_Elementary_Write_Call (N));
Analyze (N);
return;
end if;
end;
else
Rewrite (N, Build_Elementary_Write_Call (N));
Analyze (N);
return;
end if;
-- Array type case

7
gcc/ada/exp_ch7.adb
View File

@ -8290,12 +8290,11 @@ package body Exp_Ch7 is
Ref := Convert_Concurrent (Ref, Typ);
elsif Is_Private_Type (Typ)
and then Present (Full_View (Typ))
and then Is_Concurrent_Type (Full_View (Typ))
and then Is_Concurrent_Type (Underlying_Type (Typ))
then
Utyp := Corresponding_Record_Type (Full_View (Typ));
Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
Atyp := Typ;
Ref := Convert_Concurrent (Ref, Full_View (Typ));
Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
else
Utyp := Typ;

11
gcc/ada/exp_strm.adb
View File

@ -1119,25 +1119,20 @@ package body Exp_Strm is
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id;
Use_Underlying : Boolean := True)
Fnam : out Entity_Id)
is
B_Typ : Entity_Id := Base_Type (Typ);
B_Typ : constant Entity_Id := Underlying_Type (Base_Type (Typ));
Cn : Name_Id;
Constr : List_Id;
Decls : List_Id;
Discr : Entity_Id;
Discr_Elmt : Elmt_Id := No_Elmt;
Discr_Elmt : Elmt_Id := No_Elmt;
J : Pos;
Obj_Decl : Node_Id;
Odef : Node_Id;
Stms : List_Id;
begin
if Use_Underlying then
B_Typ := Underlying_Type (B_Typ);
end if;
Decls := New_List;
Constr := New_List;

7
gcc/ada/exp_strm.ads
View File

@ -108,14 +108,11 @@ package Exp_Strm is
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id;
Use_Underlying : Boolean := True);
Fnam : out Entity_Id);
-- Build function for Input attribute for record type or for an elementary
-- type (the latter is used only in the case where a user-defined Read
-- routine is defined, since, in other cases, Input calls the appropriate
-- runtime library routine directly). The flag Use_Underlying controls
-- whether the base type or the underlying type of the base type of Typ is
-- used during construction.
-- runtime library routine directly).
procedure Build_Record_Or_Elementary_Output_Procedure
(Loc : Source_Ptr;

28
gcc/ada/exp_tss.adb
View File

@ -147,27 +147,29 @@ package body Exp_Tss is
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Entity_Id
is
Btyp : Entity_Id := Typ;
Btyp : Entity_Id;
Proc : Entity_Id;
begin
loop
Btyp := Base_Type (Btyp);
Proc := TSS (Btyp, Nam);
-- If Typ is a private type, look at the full view
exit when Present (Proc)
or else not Is_Derived_Type (Btyp);
if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
Btyp := Base_Type (Full_View (Typ));
else
Btyp := Base_Type (Typ);
end if;
-- If Typ is a derived type, it may inherit attributes from some
-- ancestor.
Proc := TSS (Btyp, Nam);
Btyp := Etype (Btyp);
end loop;
-- If Typ is a derived type, it may inherit attributes from an ancestor
if No (Proc) and then Is_Derived_Type (Btyp) then
Proc := Find_Inherited_TSS (Etype (Btyp), Nam);
end if;
-- If nothing else, use the TSS of the root type
if No (Proc) then
-- If nothing else, use the TSS of the root type
Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
end if;

13
gcc/ada/sem_ch13.adb
View File

@ -4921,20 +4921,17 @@ package body Sem_Ch13 is
return;
end if;
-- Rep clause applies to full view of incomplete type or private type if
-- we have one (if not, this is a premature use of the type). However,
-- certain semantic checks need to be done on the specified entity (i.e.
-- the private view), so we save it in Ent.
-- Rep clause applies to (underlying) full view of private or incomplete
-- type if we have one (if not, this is a premature use of the type).
-- However, some semantic checks need to be done on the specified entity
-- i.e. the private view, so we save it in Ent.
if Is_Private_Type (Ent)
and then Is_Derived_Type (Ent)
and then not Is_Tagged_Type (Ent)
and then No (Full_View (Ent))
and then No (Underlying_Full_View (Ent))
then
-- If this is a private type whose completion is a derivation from
-- another private type, there is no full view, and the attribute
-- belongs to the type itself, not its underlying parent.
U_Ent := Ent;
elsif Ekind (Ent) = E_Incomplete_Type then

31
gcc/ada/sem_ch3.adb
View File

@ -7669,19 +7669,26 @@ package body Sem_Ch3 is
Full_Parent := Full_View (Full_Parent);
end if;
-- And its underlying full view if necessary
-- If the full view is itself derived from another private type
-- and has got an underlying full view, and this is done for a
-- completion, i.e. to build the underlying full view of the type,
-- then use this underlying full view. We cannot do that if this
-- is not a completion, i.e. to build the full view of the type,
-- because this would break the privacy status of the parent.
if Is_Private_Type (Full_Parent)
and then Present (Underlying_Full_View (Full_Parent))
and then Is_Completion
then
Full_Parent := Underlying_Full_View (Full_Parent);
end if;
-- 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.
-- For private, record, concurrent, access and almost all enumeration
-- types, the derivation from the full view requires a fully-fledged
-- declaration. In the other cases, just use an itype.
if Is_Record_Type (Full_Parent)
if Is_Private_Type (Full_Parent)
or else Is_Record_Type (Full_Parent)
or else Is_Concurrent_Type (Full_Parent)
or else Is_Access_Type (Full_Parent)
or else
@ -8047,7 +8054,9 @@ package body Sem_Ch3 is
end if;
-- If this is not a completion, construct the implicit full view by
-- deriving from the full view of the parent type.
-- deriving from the full view of the parent type. But if this is a
-- completion, the derived private type being built is a full view
-- and the full derivation can only be its underlying full view.
-- ??? If the parent is untagged private and its completion is
-- tagged, this mechanism will not work because we cannot derive from
@ -8055,10 +8064,16 @@ package body Sem_Ch3 is
if Present (Full_View (Parent_Type))
and then not Is_Tagged_Type (Full_View (Parent_Type))
and then not Is_Completion
and then not Error_Posted (N)
then
Build_Full_Derivation;
Set_Full_View (Derived_Type, Full_Der);
if not Is_Completion then
Set_Full_View (Derived_Type, Full_Der);
else
Set_Underlying_Full_View (Derived_Type, Full_Der);
Set_Is_Underlying_Full_View (Full_Der);
end if;
end if;
end if;