ada: Reject thin 'Unrestricted_Access value to aliased constrained array

This rejects the Unrestricted_Access attribute applied to an aliased array
with a constrained nominal subtype when its type is resolved to be a thin
pointer.  The reason is that supporting this case would require the aliased
array to contain its bounds, and this is the case only for aliased arrays
whose nominal subtype is unconstrained.

gcc/ada/

	* sem_attr.adb (Is_Thin_Pointer_To_Unc_Array): New predicate.
	(Resolve_Attribute): Apply the static matching legality rule to an
	Unrestricted_Access attribute applied to an aliased prefix if the
	type is a thin pointer.  Call Is_Thin_Pointer_To_Unc_Array for the
	aliasing legality rule as well.

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index a9e64b7655dbdbd23c9e436f6377c7640973d1fb..e6c31a6fe6411e4c2c7cab69b5e9da535b17313c 100644 (file)
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -10943,6 +10943,9 @@ package body Sem_Attr is
       --  Returns True if Declared_Entity is declared within the declarative
       --  region of Generic_Unit; otherwise returns False.
 
+      function Is_Thin_Pointer_To_Unc_Array (T : Entity_Id) return Boolean;
+      --  Return True if T is a thin pointer to an unconstrained array type
+
       ----------------------------------
       -- Declared_Within_Generic_Unit --
       ----------------------------------
@@ -10970,6 +10973,28 @@ package body Sem_Attr is
          return False;
       end Declared_Within_Generic_Unit;
 
+      ----------------------------------
+      -- Is_Thin_Pointer_To_Unc_Array --
+      ----------------------------------
+
+      function Is_Thin_Pointer_To_Unc_Array (T : Entity_Id) return Boolean is
+      begin
+         if Is_Access_Type (T)
+           and then Has_Size_Clause (T)
+           and then RM_Size (T) = System_Address_Size
+         then
+            declare
+               DT : constant Entity_Id := Designated_Type (T);
+
+            begin
+               return Is_Array_Type (DT) and then not Is_Constrained (DT);
+            end;
+
+         else
+            return False;
+         end if;
+      end Is_Thin_Pointer_To_Unc_Array;
+
    --  Start of processing for Resolve_Attribute
 
    begin
@@ -11445,9 +11470,7 @@ package body Sem_Attr is
                end if;
             end if;
 
-            if Attr_Id in Attribute_Access | Attribute_Unchecked_Access
-              and then (Ekind (Btyp) = E_General_Access_Type
-                         or else Ekind (Btyp) = E_Anonymous_Access_Type)
+            if Ekind (Btyp) in E_General_Access_Type | E_Anonymous_Access_Type
             then
                --  Ada 2005 (AI-230): Check the accessibility of anonymous
                --  access types for stand-alone objects, record and array
@@ -11455,6 +11478,7 @@ package body Sem_Attr is
                --  the level is the same of the enclosing composite type.
 
                if Ada_Version >= Ada_2005
+                 and then Attr_Id = Attribute_Access
                  and then (Is_Local_Anonymous_Access (Btyp)
 
                             --  Handle cases where Btyp is the anonymous access
@@ -11462,7 +11486,6 @@ package body Sem_Attr is
 
                             or else Nkind (Associated_Node_For_Itype (Btyp)) =
                                                         N_Object_Declaration)
-                 and then Attr_Id = Attribute_Access
 
                  --  Verify that static checking is OK (namely that we aren't
                  --  in a specific context requiring dynamic checks on
@@ -11501,7 +11524,9 @@ package body Sem_Attr is
                   end if;
                end if;
 
-               if Is_Dependent_Component_Of_Mutable_Object (P) then
+               if Attr_Id /= Attribute_Unrestricted_Access
+                 and then Is_Dependent_Component_Of_Mutable_Object (P)
+               then
                   Error_Msg_F
                     ("illegal attribute for discriminant-dependent component",
                      P);
@@ -11516,7 +11541,19 @@ package body Sem_Attr is
                   Nom_Subt := Base_Type (Nom_Subt);
                end if;
 
-               if Is_Tagged_Type (Designated_Type (Typ)) then
+               --  We do not enforce static matching for Unrestricted_Access
+               --  except for a thin pointer to an unconstrained array type,
+               --  because, in this case, the designated object must contain
+               --  its bounds, which means that it must have an unconstrained
+               --  nominal subtype (and be aliased, as will be checked below).
+
+               if Attr_Id = Attribute_Unrestricted_Access
+                 and then not (Is_Thin_Pointer_To_Unc_Array (Typ)
+                                and then Is_Aliased_View (Original_Node (P)))
+               then
+                  null;
+
+               elsif Is_Tagged_Type (Designated_Type (Typ)) then
 
                   --  If the attribute is in the context of an access
                   --  parameter, then the prefix is allowed to be of
@@ -11626,8 +11663,9 @@ package body Sem_Attr is
 
                   Compatible_Alt_Checks : constant Boolean :=
                     No_Dynamic_Acc_Checks and then not Debug_Flag_Underscore_B;
+
                begin
-                  if Attr_Id /= Attribute_Unchecked_Access
+                  if Attr_Id = Attribute_Access
                     and then (Ekind (Btyp) = E_General_Access_Type
                                or else No_Dynamic_Acc_Checks)
 
@@ -11817,22 +11855,12 @@ package body Sem_Attr is
                --  Check for unrestricted access where expected type is a thin
                --  pointer to an unconstrained array.
 
-               elsif Has_Size_Clause (Typ)
-                 and then RM_Size (Typ) = System_Address_Size
-               then
-                  declare
-                     DT : constant Entity_Id := Designated_Type (Typ);
-                  begin
-                     if Is_Array_Type (DT)
-                       and then not Is_Constrained (DT)
-                     then
-                        Error_Msg_N
-                          ("illegal use of Unrestricted_Access attribute", P);
-                        Error_Msg_N
-                          ("\attempt to generate thin pointer to unaliased "
-                           & "object", P);
-                     end if;
-                  end;
+               elsif Is_Thin_Pointer_To_Unc_Array (Typ) then
+                  Error_Msg_N
+                    ("illegal use of Unrestricted_Access attribute", P);
+                  Error_Msg_N
+                    ("\attempt to generate thin pointer to unaliased "
+                     & "object", P);
                end if;
             end if;