diff mbox series

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

Message ID 20200604091255.GA134691@adacore.com
State New
Headers show
Series [Ada] Alignment clause ignored on completion derived from private type | expand

Commit Message

Pierre-Marie de Rodat June 4, 2020, 9:12 a.m. UTC 
This fixes the discrepancy visible between an alignment clause put
on a type derived from a private type and an alignment clause put
on a completion derived from the same private type, for example:

with System.OS_Interface;

package P is
  type T is limited private;
  type V is new System.OS_Interface.pthread_mutex_t;
  for V'Alignment use 64;
private
  type T is new System.OS_Interface.pthread_mutex_t;
  for T'Alignment use 64;
end P;

Whereas the alignment clause on V is honored, the one on T is ignored.

This discrepancy occurs because the front-end builds an implicit full
view for V, derived from the full view of the parent, that can carry
the alignment, but it doesn't do it for T; as a matter of fact, that's
correct because a completion cannot have a full view since it's itself
the full view of another entity, but it can have an _underlying_ full
view, which happens in other circumstances (discriminated types).

Therefore the change causes the front-end to build an underlying full
view in this case too and to propagate the alignment clause down to it.
This has exposed a small breach of privacy when such a chain of views
is itself derived, which is fixed.  This also has required adjustments
in the handling of Type Support Subprograms (TSS) to look up the new
underlying full views.

This causes more entities to be generated in the front-end, but the
increase should be small on average because these cases are rare.

Tested on x86_64-pc-linux-gnu, committed on trunk

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 mbox series

Patch

--- gcc/ada/exp_attr.adb
+++ 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
 

--- gcc/ada/exp_ch7.adb
+++ 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;

--- gcc/ada/exp_strm.adb
+++ 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;
 

--- gcc/ada/exp_strm.ads
+++ 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;

--- gcc/ada/exp_tss.adb
+++ 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;
 

--- gcc/ada/sem_ch13.adb
+++ 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

--- gcc/ada/sem_ch3.adb
+++ 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;