From a3fbeceef46546fd47ed370474feed347c86713f Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 27 Jan 2020 12:50:23 +0100 Subject: [PATCH] [Ada] Alignment clause ignored on completion derived from private type 2020-06-04 Eric Botcazou gcc/ada/ * exp_attr.adb (xpand_N_Attribute_Reference) : Call Find_Inherited_TSS to look up the Stream_Read TSS. : 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. --- 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; -- 2.30.2