diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index c35fea3eae5..2f6dc3a989f 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -11436,7 +11436,7 @@ package body Exp_Ch4 is begin -- Nothing else to do if no change of representation - if Same_Representation (Operand_Type, Target_Type) then + if Has_Compatible_Representation (Target_Type, Operand_Type) then return; -- The real change of representation work is done by the assignment @@ -12454,7 +12454,7 @@ package body Exp_Ch4 is -- Special processing is required if there is a change of -- representation (from enumeration representation clauses). - if not Same_Representation (Target_Type, Operand_Type) + if not Has_Compatible_Representation (Target_Type, Operand_Type) and then not Conversion_OK (N) then diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index afd3bca5014..8482f300735 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -278,8 +278,9 @@ package body Exp_Ch5 is begin return Nkind (Rhs) = N_Type_Conversion - and then - not Same_Representation (Etype (Rhs), Etype (Expression (Rhs))); + and then not Has_Compatible_Representation + (Target_Type => Etype (Rhs), + Operand_Type => Etype (Expression (Rhs))); end Change_Of_Representation; ------------------------------ diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 41ed7646f15..38864933b44 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1571,8 +1571,9 @@ package body Exp_Ch6 is Var := Make_Var (Expression (Actual)); - Crep := not Same_Representation - (F_Typ, Etype (Expression (Actual))); + Crep := not Has_Compatible_Representation + (Target_Type => F_Typ, + Operand_Type => Etype (Expression (Actual))); else V_Typ := Etype (Actual); @@ -2373,9 +2374,9 @@ package body Exp_Ch6 is -- Also pass by copy if change of representation - or else not Same_Representation - (Etype (Formal), - Etype (Expression (Actual)))) + or else not Has_Compatible_Representation + (Target_Type => Etype (Formal), + Operand_Type => Etype (Expression (Actual)))) then Add_Call_By_Copy_Code; @@ -4801,7 +4802,10 @@ package body Exp_Ch6 is -- If there is a change of representation, then generate a -- warning, and do the change of representation. - elsif not Same_Representation (Formal_Typ, Parent_Typ) then + elsif not Has_Compatible_Representation + (Target_Type => Formal_Typ, + Operand_Type => Parent_Typ) + then Error_Msg_N ("??change of representation required", Actual); Convert (Actual, Parent_Typ); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 78da069ba10..2439169cba9 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -10556,6 +10556,13 @@ package body Sem_Attr is -- Returns True if Declared_Entity is declared within the declarative -- region of Generic_Unit; otherwise returns False. + function Prefix_With_Safe_Accessibility_Level return Boolean; + -- Return True if the prefix does not have a value conversion of an + -- array because a value conversion is like an aggregate with respect + -- to determining accessibility level (RM 3.10.2); even if evaluation + -- of a value conversion is guaranteed to not create a new object, + -- accessibility rules are defined as if it might. + --------------------------- -- Accessibility_Message -- --------------------------- @@ -10632,6 +10639,73 @@ package body Sem_Attr is return False; end Declared_Within_Generic_Unit; + ------------------------------------------ + -- Prefix_With_Safe_Accessibility_Level -- + ------------------------------------------ + + function Prefix_With_Safe_Accessibility_Level return Boolean is + function Safe_Value_Conversions return Boolean; + -- Return False if the prefix has a value conversion of an array type + + ---------------------------- + -- Safe_Value_Conversions -- + ---------------------------- + + function Safe_Value_Conversions return Boolean is + PP : Node_Id := P; + + begin + loop + if Nkind_In (PP, N_Selected_Component, + N_Indexed_Component) + then + PP := Prefix (PP); + + elsif Comes_From_Source (PP) + and then Nkind_In (PP, N_Type_Conversion, + N_Unchecked_Type_Conversion) + and then Is_Array_Type (Etype (PP)) + then + return False; + + elsif Comes_From_Source (PP) + and then Nkind (PP) = N_Qualified_Expression + and then Is_Array_Type (Etype (PP)) + and then Nkind_In (Original_Node (Expression (PP)), + N_Aggregate, + N_Extension_Aggregate) + then + return False; + + else + exit; + end if; + end loop; + + return True; + end Safe_Value_Conversions; + + -- Start of processing for Prefix_With_Safe_Accessibility_Level + + begin + -- No check required for unchecked and unrestricted access + + if Attr_Id = Attribute_Unchecked_Access + or else Attr_Id = Attribute_Unrestricted_Access + then + return True; + + -- Check value conversions + + elsif Ekind (Btyp) = E_General_Access_Type + and then not Safe_Value_Conversions + then + return False; + end if; + + return True; + end Prefix_With_Safe_Accessibility_Level; + -- Start of processing for Resolve_Attribute begin @@ -11473,6 +11547,15 @@ package body Sem_Attr is end if; end if; + -- Check that the prefix does not have a value conversion of an + -- array type since a value conversion is like an aggregate with + -- respect to determining accessibility level (RM 3.10.2). + + if not Prefix_With_Safe_Accessibility_Level then + Accessibility_Message; + return; + end if; + -- Mark that address of entity is taken in case of -- 'Unrestricted_Access or in case of a subprogram. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5ed468e59fd..ec25e3d6eb4 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -12792,6 +12792,234 @@ package body Sem_Ch13 is end if; end Get_Alignment_Value; + ----------------------------------- + -- Has_Compatible_Representation -- + ----------------------------------- + + function Has_Compatible_Representation + (Target_Type, Operand_Type : Entity_Id) return Boolean + is + T1 : constant Entity_Id := Underlying_Type (Target_Type); + T2 : constant Entity_Id := Underlying_Type (Operand_Type); + + begin + -- A quick check, if base types are the same, then we definitely have + -- the same representation, because the subtype specific representation + -- attributes (Size and Alignment) do not affect representation from + -- the point of view of this test. + + if Base_Type (T1) = Base_Type (T2) then + return True; + + elsif Is_Private_Type (Base_Type (T2)) + and then Base_Type (T1) = Full_View (Base_Type (T2)) + then + return True; + + -- If T2 is a generic actual it is declared as a subtype, so + -- check against its base type. + + elsif Is_Generic_Actual_Type (T1) + and then Has_Compatible_Representation (Base_Type (T1), T2) + then + return True; + end if; + + -- Tagged types always have the same representation, because it is not + -- possible to specify different representations for common fields. + + if Is_Tagged_Type (T1) then + return True; + end if; + + -- Representations are definitely different if conventions differ + + if Convention (T1) /= Convention (T2) then + return False; + end if; + + -- Representations are different if component alignments or scalar + -- storage orders differ. + + if (Is_Record_Type (T1) or else Is_Array_Type (T1)) + and then + (Is_Record_Type (T2) or else Is_Array_Type (T2)) + and then + (Component_Alignment (T1) /= Component_Alignment (T2) + or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) + then + return False; + end if; + + -- For arrays, the only real issue is component size. If we know the + -- component size for both arrays, and it is the same, then that's + -- good enough to know we don't have a change of representation. + + if Is_Array_Type (T1) then + + -- In a view conversion, if the target type is an array type having + -- aliased components and the operand type is an array type having + -- unaliased components, then a new object is created (4.6(58.3/4)). + + if Has_Aliased_Components (T1) + and then not Has_Aliased_Components (T2) + then + return False; + end if; + + if Known_Component_Size (T1) + and then Known_Component_Size (T2) + and then Component_Size (T1) = Component_Size (T2) + then + return True; + end if; + end if; + + -- For records, representations are different if reorderings differ + + if Is_Record_Type (T1) + and then Is_Record_Type (T2) + and then No_Reordering (T1) /= No_Reordering (T2) + then + return False; + end if; + + -- Types definitely have same representation if neither has non-standard + -- representation since default representations are always consistent. + -- If only one has non-standard representation, and the other does not, + -- then we consider that they do not have the same representation. They + -- might, but there is no way of telling early enough. + + if Has_Non_Standard_Rep (T1) then + if not Has_Non_Standard_Rep (T2) then + return False; + end if; + else + return not Has_Non_Standard_Rep (T2); + end if; + + -- Here the two types both have non-standard representation, and we need + -- to determine if they have the same non-standard representation. + + -- For arrays, we simply need to test if the component sizes are the + -- same. Pragma Pack is reflected in modified component sizes, so this + -- check also deals with pragma Pack. + + if Is_Array_Type (T1) then + return Component_Size (T1) = Component_Size (T2); + + -- Case of record types + + elsif Is_Record_Type (T1) then + + -- Packed status must conform + + if Is_Packed (T1) /= Is_Packed (T2) then + return False; + + -- Otherwise we must check components. Typ2 maybe a constrained + -- subtype with fewer components, so we compare the components + -- of the base types. + + else + Record_Case : declare + CD1, CD2 : Entity_Id; + + function Same_Rep return Boolean; + -- CD1 and CD2 are either components or discriminants. This + -- function tests whether they have the same representation. + + -------------- + -- Same_Rep -- + -------------- + + function Same_Rep return Boolean is + begin + if No (Component_Clause (CD1)) then + return No (Component_Clause (CD2)); + else + -- Note: at this point, component clauses have been + -- normalized to the default bit order, so that the + -- comparison of Component_Bit_Offsets is meaningful. + + return + Present (Component_Clause (CD2)) + and then + Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2) + and then + Esize (CD1) = Esize (CD2); + end if; + end Same_Rep; + + -- Start of processing for Record_Case + + begin + if Has_Discriminants (T1) then + + -- The number of discriminants may be different if the + -- derived type has fewer (constrained by values). The + -- invisible discriminants retain the representation of + -- the original, so the discrepancy does not per se + -- indicate a different representation. + + CD1 := First_Discriminant (T1); + CD2 := First_Discriminant (T2); + while Present (CD1) and then Present (CD2) loop + if not Same_Rep then + return False; + else + Next_Discriminant (CD1); + Next_Discriminant (CD2); + end if; + end loop; + end if; + + CD1 := First_Component (Underlying_Type (Base_Type (T1))); + CD2 := First_Component (Underlying_Type (Base_Type (T2))); + while Present (CD1) loop + if not Same_Rep then + return False; + else + Next_Component (CD1); + Next_Component (CD2); + end if; + end loop; + + return True; + end Record_Case; + end if; + + -- For enumeration types, we must check each literal to see if the + -- representation is the same. Note that we do not permit enumeration + -- representation clauses for Character and Wide_Character, so these + -- cases were already dealt with. + + elsif Is_Enumeration_Type (T1) then + Enumeration_Case : declare + L1, L2 : Entity_Id; + + begin + L1 := First_Literal (T1); + L2 := First_Literal (T2); + while Present (L1) loop + if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then + return False; + else + Next_Literal (L1); + Next_Literal (L2); + end if; + end loop; + + return True; + end Enumeration_Case; + + -- Any other types have the same representation for these purposes + + else + return True; + end if; + end Has_Compatible_Representation; + ------------------------------------- -- Inherit_Aspects_At_Freeze_Point -- ------------------------------------- @@ -14657,221 +14885,6 @@ package body Sem_Ch13 is end loop; end Resolve_Aspect_Expressions; - ------------------------- - -- Same_Representation -- - ------------------------- - - function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is - T1 : constant Entity_Id := Underlying_Type (Typ1); - T2 : constant Entity_Id := Underlying_Type (Typ2); - - begin - -- A quick check, if base types are the same, then we definitely have - -- the same representation, because the subtype specific representation - -- attributes (Size and Alignment) do not affect representation from - -- the point of view of this test. - - if Base_Type (T1) = Base_Type (T2) then - return True; - - elsif Is_Private_Type (Base_Type (T2)) - and then Base_Type (T1) = Full_View (Base_Type (T2)) - then - return True; - - -- If T2 is a generic actual it is declared as a subtype, so - -- check against its base type. - - elsif Is_Generic_Actual_Type (T1) - and then Same_Representation (Base_Type (T1), T2) - then - return True; - end if; - - -- Tagged types always have the same representation, because it is not - -- possible to specify different representations for common fields. - - if Is_Tagged_Type (T1) then - return True; - end if; - - -- Representations are definitely different if conventions differ - - if Convention (T1) /= Convention (T2) then - return False; - end if; - - -- Representations are different if component alignments or scalar - -- storage orders differ. - - if (Is_Record_Type (T1) or else Is_Array_Type (T1)) - and then - (Is_Record_Type (T2) or else Is_Array_Type (T2)) - and then - (Component_Alignment (T1) /= Component_Alignment (T2) - or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) - then - return False; - end if; - - -- For arrays, the only real issue is component size. If we know the - -- component size for both arrays, and it is the same, then that's - -- good enough to know we don't have a change of representation. - - if Is_Array_Type (T1) then - if Known_Component_Size (T1) - and then Known_Component_Size (T2) - and then Component_Size (T1) = Component_Size (T2) - then - return True; - end if; - end if; - - -- For records, representations are different if reorderings differ - - if Is_Record_Type (T1) - and then Is_Record_Type (T2) - and then No_Reordering (T1) /= No_Reordering (T2) - then - return False; - end if; - - -- Types definitely have same representation if neither has non-standard - -- representation since default representations are always consistent. - -- If only one has non-standard representation, and the other does not, - -- then we consider that they do not have the same representation. They - -- might, but there is no way of telling early enough. - - if Has_Non_Standard_Rep (T1) then - if not Has_Non_Standard_Rep (T2) then - return False; - end if; - else - return not Has_Non_Standard_Rep (T2); - end if; - - -- Here the two types both have non-standard representation, and we need - -- to determine if they have the same non-standard representation. - - -- For arrays, we simply need to test if the component sizes are the - -- same. Pragma Pack is reflected in modified component sizes, so this - -- check also deals with pragma Pack. - - if Is_Array_Type (T1) then - return Component_Size (T1) = Component_Size (T2); - - -- Case of record types - - elsif Is_Record_Type (T1) then - - -- Packed status must conform - - if Is_Packed (T1) /= Is_Packed (T2) then - return False; - - -- Otherwise we must check components. Typ2 maybe a constrained - -- subtype with fewer components, so we compare the components - -- of the base types. - - else - Record_Case : declare - CD1, CD2 : Entity_Id; - - function Same_Rep return Boolean; - -- CD1 and CD2 are either components or discriminants. This - -- function tests whether they have the same representation. - - -------------- - -- Same_Rep -- - -------------- - - function Same_Rep return Boolean is - begin - if No (Component_Clause (CD1)) then - return No (Component_Clause (CD2)); - else - -- Note: at this point, component clauses have been - -- normalized to the default bit order, so that the - -- comparison of Component_Bit_Offsets is meaningful. - - return - Present (Component_Clause (CD2)) - and then - Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2) - and then - Esize (CD1) = Esize (CD2); - end if; - end Same_Rep; - - -- Start of processing for Record_Case - - begin - if Has_Discriminants (T1) then - - -- The number of discriminants may be different if the - -- derived type has fewer (constrained by values). The - -- invisible discriminants retain the representation of - -- the original, so the discrepancy does not per se - -- indicate a different representation. - - CD1 := First_Discriminant (T1); - CD2 := First_Discriminant (T2); - while Present (CD1) and then Present (CD2) loop - if not Same_Rep then - return False; - else - Next_Discriminant (CD1); - Next_Discriminant (CD2); - end if; - end loop; - end if; - - CD1 := First_Component (Underlying_Type (Base_Type (T1))); - CD2 := First_Component (Underlying_Type (Base_Type (T2))); - while Present (CD1) loop - if not Same_Rep then - return False; - else - Next_Component (CD1); - Next_Component (CD2); - end if; - end loop; - - return True; - end Record_Case; - end if; - - -- For enumeration types, we must check each literal to see if the - -- representation is the same. Note that we do not permit enumeration - -- representation clauses for Character and Wide_Character, so these - -- cases were already dealt with. - - elsif Is_Enumeration_Type (T1) then - Enumeration_Case : declare - L1, L2 : Entity_Id; - - begin - L1 := First_Literal (T1); - L2 := First_Literal (T2); - while Present (L1) loop - if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then - return False; - else - Next_Literal (L1); - Next_Literal (L2); - end if; - end loop; - - return True; - end Enumeration_Case; - - -- Any other types have the same representation for these purposes - - else - return True; - end if; - end Same_Representation; - ---------------------------- -- Parse_Aspect_Aggregate -- ---------------------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 43aea2a7aa6..3d24c04d1a8 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -128,6 +128,14 @@ package Sem_Ch13 is -- If the size is too small, and an error message is given, then both -- Esize and RM_Size are reset to the allowed minimum value in T. + function Has_Compatible_Representation + (Target_Type, Operand_Type : Entity_Id) return Boolean; + -- Given two types, where the two types are related by possible derivation, + -- determines if the two types have compatible representation, or different + -- representations, requiring the special processing for representation + -- change. A False result is possible only for array, enumeration or + -- record types. + procedure Parse_Aspect_Aggregate (N : Node_Id; Empty_Subp : in out Node_Id; @@ -196,13 +204,6 @@ package Sem_Ch13 is -- because such clauses are linked on to the Rep_Item chain in procedure -- Sem_Ch13.Analyze_Aspect_Specifications. See that procedure for details. - function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean; - -- Given two types, where the two types are related by possible derivation, - -- determines if the two types have the same representation, or different - -- representations, requiring the special processing for representation - -- change. A False result is possible only for array, enumeration or - -- record types. - procedure Validate_Unchecked_Conversion (N : Node_Id; Act_Unit : Entity_Id); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f1c01779b91..bf4774c4491 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4118,25 +4118,9 @@ package body Sem_Res is if Ekind (F) = E_In_Out_Parameter and then Is_Array_Type (Etype (F)) then - -- In a view conversion, the conversion must be legal in - -- both directions, and thus both component types must be - -- aliased, or neither (4.6 (8)). - - -- The extra rule in 4.6 (24.9.2) seems unduly - -- restrictive: the privacy requirement should not apply - -- to generic types, and should be checked in an - -- instance. ARG query is in order ??? - - if Has_Aliased_Components (Expr_Typ) /= - Has_Aliased_Components (Etype (F)) - then - Error_Msg_N - ("both component types in a view conversion must be" - & " aliased, or neither", A); - -- Comment here??? what set of cases??? - elsif not Same_Ancestor (Etype (F), Expr_Typ) then + if not Same_Ancestor (Etype (F), Expr_Typ) then -- Check view conv between unrelated by ref array -- types.