From 4fc2610a8301198367c590759a578b03167a1868 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 17 Jan 2020 19:37:39 +0100 Subject: [Ada] Fix for missing calls to Adjust primitive with nested generics 2020-06-03 Eric Botcazou gcc/ada/ * sem_ch12.adb (Denotes_Previous_Actual): Delete. (Check_Generic_Actuals): Do not special case array types whose component type denotes a previous actual. Do not special case access types whose base type is private. (Check_Private_View): Remove code dealing with secondary types. Do not switch the views of an array because of its component. (Copy_Generic_Node): Add special handling for a comparison operator on array types. (Instantiate_Type): Do not special case access types whose designated type is private. (Set_Global_Type): Do not special case array types whose component type is private. --- gcc/ada/sem_ch12.adb | 207 ++++++++++++++++++++------------------------------- 1 file changed, 81 insertions(+), 126 deletions(-) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 71e1212..32a6333 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6794,48 +6794,6 @@ package body Sem_Ch12 is E : Entity_Id; Astype : Entity_Id; - function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean; - -- For a formal that is an array type, the component type is often a - -- previous formal in the same unit. The privacy status of the component - -- type will have been examined earlier in the traversal of the - -- corresponding actuals, and this status should not be modified for - -- the array (sub)type itself. However, if the base type of the array - -- (sub)type is private, its full view must be restored in the body to - -- be consistent with subsequent index subtypes, etc. - -- - -- To detect this case we have to rescan the list of formals, which is - -- usually short enough to ignore the resulting inefficiency. - - ----------------------------- - -- Denotes_Previous_Actual -- - ----------------------------- - - function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is - Prev : Entity_Id; - - begin - Prev := First_Entity (Instance); - while Present (Prev) loop - if Is_Type (Prev) - and then Nkind (Parent (Prev)) = N_Subtype_Declaration - and then Is_Entity_Name (Subtype_Indication (Parent (Prev))) - and then Entity (Subtype_Indication (Parent (Prev))) = Typ - then - return True; - - elsif Prev = E then - return False; - - else - Next_Entity (Prev); - end if; - end loop; - - return False; - end Denotes_Previous_Actual; - - -- Start of processing for Check_Generic_Actuals - begin E := First_Entity (Instance); while Present (E) loop @@ -6844,14 +6802,7 @@ package body Sem_Ch12 is and then Scope (Etype (E)) /= Instance and then Is_Entity_Name (Subtype_Indication (Parent (E))) then - if Is_Array_Type (E) - and then not Is_Private_Type (Etype (E)) - and then Denotes_Previous_Actual (Component_Type (E)) - then - null; - else - Check_Private_View (Subtype_Indication (Parent (E))); - end if; + Check_Private_View (Subtype_Indication (Parent (E))); Set_Is_Generic_Actual_Type (E); @@ -6886,15 +6837,6 @@ package body Sem_Ch12 is if Is_Discrete_Or_Fixed_Point_Type (E) then Set_RM_Size (E, RM_Size (Astype)); - - -- In nested instances, the base type of an access actual may - -- itself be private, and need to be exchanged. - - elsif Is_Access_Type (E) - and then Is_Private_Type (Etype (E)) - then - Check_Private_View - (New_Occurrence_Of (Etype (E), Sloc (Instance))); end if; elsif Ekind (E) = E_Package then @@ -7451,63 +7393,6 @@ package body Sem_Ch12 is Prepend_Elmt (T, Exchanged_Views); Exchange_Declarations (Etype (Get_Associated_Node (N))); - -- For composite types with inconsistent representation exchange - -- component types accordingly. - - elsif Is_Access_Type (T) - and then Is_Private_Type (Designated_Type (T)) - and then not Has_Private_View (N) - and then Present (Full_View (Designated_Type (T))) - then - Switch_View (Designated_Type (T)); - - elsif Is_Array_Type (T) then - if Is_Private_Type (Component_Type (T)) - and then not Has_Private_View (N) - and then Present (Full_View (Component_Type (T))) - then - Switch_View (Component_Type (T)); - end if; - - -- The normal exchange mechanism relies on the setting of a - -- flag on the reference in the generic. However, an additional - -- mechanism is needed for types that are not explicitly - -- mentioned in the generic, but may be needed in expanded code - -- in the instance. This includes component types of arrays and - -- designated types of access types. This processing must also - -- include the index types of arrays which we take care of here. - - declare - Indx : Node_Id; - Typ : Entity_Id; - - begin - Indx := First_Index (T); - while Present (Indx) loop - Typ := Base_Type (Etype (Indx)); - - if Is_Private_Type (Typ) - and then Present (Full_View (Typ)) - then - Switch_View (Typ); - end if; - - Next_Index (Indx); - end loop; - end; - - -- The following case does not test Has_Private_View (N) so it may - -- end up switching views when they are not supposed to be switched. - -- This might be in keeping with Set_Global_Type setting the flag - -- for an array type even if it is not private ??? - - elsif Is_Private_Type (T) - and then Present (Full_View (T)) - and then Is_Array_Type (Full_View (T)) - and then Is_Private_Type (Component_Type (Full_View (T))) - then - Switch_View (T); - -- Finally, a non-private subtype may have a private base type, which -- must be exchanged for consistency. This can happen when a package -- body is instantiated, when the scope stack is empty but in fact @@ -7911,6 +7796,85 @@ package body Sem_Ch12 is Set_Entity (New_N, Entity (Assoc)); Check_Private_View (N); + -- Here we deal with a very peculiar case for which the + -- Has_Private_View mechanism is not sufficient, because + -- the reference to the type is implicit in the tree, + -- that is to say, it's not referenced from a node but + -- only from another type, namely through Component_Type. + + -- package P is + + -- type Pt is private; + + -- generic + -- type Ft is array (Positive range <>) of Pt; + -- package G is + -- procedure Check (F1, F2 : Ft; Lt : Boolean); + -- end G; + + -- private + -- type Pt is new Boolean; + -- end P; + + -- package body P is + -- package body G is + -- procedure Check (F1, F2 : Ft; Lt : Boolean) is + -- begin + -- if (F1 < F2) /= Lt then + -- null; + -- end if; + -- end Check; + -- end G; + -- end P; + + -- type Arr is array (Positive range <>) of P.Pt; + + -- package Inst is new P.G (Arr); + + -- Pt is a global type for the generic package G and it + -- is not referenced in its body, but only as component + -- type of Ft, which is a local type. This means that no + -- references to Pt or Ft are seen during the copy of the + -- body, the only reference to Pt being seen is when the + -- actuals are checked by Check_Generic_Actuals, but Pt + -- is still private at this point. In the end, the views + -- of Pt are not switched in the body and, therefore, the + -- array comparison is rejected because the component is + -- still private. + + -- Adding e.g. a dummy variable of type Pt in the body is + -- sufficient to make everything work, so we generate an + -- artificial reference to Pt on the fly and thus force + -- the switcthing of views on the ground that, if the + -- comparison was accepted during the semantics analysis + -- of the generic, this means that the component cannot + -- have been private (see Sem_Type.Valid_Comparison_Arg). + + if Nkind (Assoc) in N_Op_Compare + and then Present (Etype (Left_Opnd (Assoc))) + and then Is_Array_Type (Etype (Left_Opnd (Assoc))) + and then Present (Etype (Right_Opnd (Assoc))) + and then Is_Array_Type (Etype (Right_Opnd (Assoc))) + then + declare + Ltyp : constant Entity_Id := + Etype (Left_Opnd (Assoc)); + Rtyp : constant Entity_Id := + Etype (Right_Opnd (Assoc)); + begin + if Is_Private_Type (Component_Type (Ltyp)) then + Check_Private_View + (New_Occurrence_Of (Component_Type (Ltyp), + Sloc (N))); + end if; + if Is_Private_Type (Component_Type (Rtyp)) then + Check_Private_View + (New_Occurrence_Of (Component_Type (Rtyp), + Sloc (N))); + end if; + end; + end if; + -- The node is a reference to a global type and acts as the -- subtype mark of a qualified expression created in order -- to aid resolution of accidental overloading in instances. @@ -13641,11 +13605,6 @@ package body Sem_Ch12 is if Is_Private_Type (Act_T) then Set_Has_Private_View (Subtype_Indication (Decl_Node)); - - elsif Is_Access_Type (Act_T) - and then Is_Private_Type (Designated_Type (Act_T)) - then - Set_Has_Private_View (Subtype_Indication (Decl_Node)); end if; -- In Ada 2012 the actual may be a limited view. Indicate that @@ -15213,11 +15172,7 @@ package body Sem_Ch12 is -- If not a private type, nothing else to do if not Is_Private_Type (Typ) then - if Is_Array_Type (Typ) - and then Is_Private_Type (Component_Type (Typ)) - then - Set_Has_Private_View (N); - end if; + null; -- If it is a derivation of a private type in a context where no -- full view is needed, nothing to do either. -- cgit v1.1