public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc/devel/c++-modules] [Ada] Alignment clause ignored on completion derived from private type
@ 2020-06-11 13:14 Nathan Sidwell
0 siblings, 0 replies; only message in thread
From: Nathan Sidwell @ 2020-06-11 13:14 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:a3fbeceef46546fd47ed370474feed347c86713f
commit a3fbeceef46546fd47ed370474feed347c86713f
Author: Eric Botcazou <ebotcazou@adacore.com>
Date: Mon Jan 27 12:50:23 2020 +0100
[Ada] Alignment clause ignored on completion derived from private type
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.
Diff:
---
gcc/ada/exp_attr.adb | 56 +++++++++++++++++++---------------------------------
gcc/ada/exp_ch7.adb | 7 +++----
gcc/ada/exp_strm.adb | 11 +++--------
gcc/ada/exp_strm.ads | 7 ++-----
gcc/ada/exp_tss.adb | 26 +++++++++++++-----------
gcc/ada/sem_ch13.adb | 13 +++++-------
gcc/ada/sem_ch3.adb | 31 +++++++++++++++++++++--------
7 files changed, 70 insertions(+), 81 deletions(-)
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 8ca5eb15158..d8831beeb7c 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -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 (TSS (Base_Type (Typ), TSS_Stream_Write)) then
- Build_Record_Or_Elementary_Output_Procedure
- (Loc, Typ, Decl, Pname);
- Insert_Action (N, Decl);
+ 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);
- -- 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
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 276ffa0dd68..9d7ed1229b0 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -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;
diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb
index cbdefc9937d..045305b5d69 100644
--- a/gcc/ada/exp_strm.adb
+++ b/gcc/ada/exp_strm.adb
@@ -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;
diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads
index 3c146cf8e0b..d77d7564639 100644
--- a/gcc/ada/exp_strm.ads
+++ b/gcc/ada/exp_strm.ads
@@ -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;
diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb
index d00197f150b..fc2338f8b02 100644
--- a/gcc/ada/exp_tss.adb
+++ b/gcc/ada/exp_tss.adb
@@ -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) then
+ 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 nothing else, use the TSS of the root type
+ if No (Proc) then
Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
end if;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 13bed50cffe..bdb2b6a5144 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -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
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index dcf07015e1c..8d86bc7d4cb 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -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;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2020-06-11 13:14 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-06-11 13:14 [gcc/devel/c++-modules] [Ada] Alignment clause ignored on completion derived from private type Nathan Sidwell
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).