[Ada] Ada2020: AI12-0027 Access values and unaliased component

Access values should never designate unaliased components.
This new feature is documented in AI12-0027-1.

gcc/ada/

	* sem_ch13.ads (Same_Representation): Renamed as
	Has_Compatible_Representation because now the order of the arguments
	are taken into account; its formals are also renamed as Target_Type
	and Operand_Type.
	* sem_ch13.adb (Same_Representation): Renamed and moved to place the
	routine in alphabetic order.
	* sem_attr.adb (Prefix_With_Safe_Accessibility_Level): New subprogram.
	(Resolve_Attribute): Check that the prefix of attribute Access
	does not have a value conversion of an array type.
	* sem_res.adb (Resolve_Actuals): Remove restrictive check on view
	conversions which required matching value of Has_Aliased_Components of
	formals and actuals.
	* exp_ch4.adb (Handle_Changed_Representation): Update call to
	Same_Representation.
	(Expand_N_Type_Conversion): Update call to Same_Representation.
	* exp_ch5.adb (Change_Of_Representation): Update call to
	Same_Representation.
	* exp_ch6.adb (Add_Call_By_Copy_Code): Update call to
	Same_Representation.
	(Expand_Actuals): Update call to Same_Representation.
	(Expand_Call_Helper): Update call to Same_Representation.

7 files changed, 335 insertions, 249 deletions

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.