[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 --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 8ca5eb15158419bd90b12d2422104b83f08c787e..d8831beeb7c62391e8aba24c7de7ecddf125ece7 100644 (file)
--- 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 276ffa0dd687fbddf5cac4ef1633b97385787c16..9d7ed1229b04207b9f8fc6d74aad401a44264218 100644 (file)
--- 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 cbdefc9937d807f29449760f94fe6cd0fc2fe3a7..045305b5d6908960f868a81d248c42fac1cc5d59 100644 (file)
--- 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 3c146cf8e0ba336826f945d69ca60542774cdc2f..d77d756463993b6ad9d1ae53c5f93e0f467650d4 100644 (file)
--- 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 d00197f150bc80a88dc8ac10da13bc21c4165130..fc2338f8b0274f540e735998f26780bc7705fd04 100644 (file)
--- 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 13bed50cffea35ffb2bbcc9ca8872b93d40febf7..bdb2b6a514495177b8642762531dff5100aac83a 100644 (file)
--- 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 dcf07015e1cbdc377d41288d63456b70e60dd142..8d86bc7d4cbd677b1d670fe2753489cf03e39690 100644 (file)
--- 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;