[Ada] Catch newly illegal case of Unrestricted_Access

Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi	(revision 212654)
+++ gnat_rm.texi	(working copy)
@@ -9551,22 +9551,65 @@ 
 
 It is possible to use @code{Unrestricted_Access} for any type, but care
 must be exercised if it is used to create pointers to unconstrained array
-objects. In this case, the resulting pointer has the same scope as the
+objects.  In this case, the resulting pointer has the same scope as the
 context of the attribute, and may not be returned to some enclosing
-scope. For instance, a function cannot use @code{Unrestricted_Access}
+scope.  For instance, a function cannot use @code{Unrestricted_Access}
 to create a unconstrained pointer and then return that value to the
-caller. In addition, it is only valid to create pointers to unconstrained
+caller.  In addition, it is only valid to create pointers to unconstrained
 arrays using this attribute if the pointer has the normal default ``fat''
 representation where a pointer has two components, one points to the array
-and one points to the bounds. If a size clause is used to force ``thin''
+and one points to the bounds.  If a size clause is used to force ``thin''
 representation for a pointer to unconstrained where there is only space for
-a single pointer, then any use of @code{Unrestricted_Access}
-to create a value of such a type (e.g. by conversion from fat to
-thin pointers) is erroneous. Consider the following example:
+a single pointer, then the resulting pointer is not usable.
 
+In the simple case where a direct use of Unrestricted_Access attempts
+to make a thin pointer for a non-aliased object, the compiler will
+reject the use as illegal, as shown in the following example:
+
 @smallexample @c ada
 with System; use System;
+procedure SliceUA2 is
+   type A is access all String;
+   for A'Size use Standard'Address_Size;
+
+   procedure P (Arg : A) is
+   begin
+      null;
+   end P;
+
+   X : String := "hello world!";
+   X2 : aliased String := "hello world!";
+
+   AV : A := X'Unrestricted_Access;    -- ERROR
+             |
+>>> illegal use of Unrestricted_Access attribute
+>>> attempt to generate thin pointer to unaliased object
+
+begin
+   P (X'Unrestricted_Access);          -- ERROR
+      |
+>>> illegal use of Unrestricted_Access attribute
+>>> attempt to generate thin pointer to unaliased object
+
+   P (X(7 .. 12)'Unrestricted_Access); -- ERROR
+      |
+>>> illegal use of Unrestricted_Access attribute
+>>> attempt to generate thin pointer to unaliased object
+
+   P (X2'Unrestricted_Access);         -- OK
+end;
+@end smallexample
+
+@noindent
+but other cases cannot be detected by the compiler, and are
+considered to be erroneous. Consider the following example:
+
+@smallexample @c ada
+with System; use System;
+with System; use System;
 procedure SliceUA is
+   type AF is access all String;
+
    type A is access all String;
    for A'Size use Standard'Address_Size;
 
@@ -9578,28 +9621,29 @@ 
    end P;
 
    X : String := "hello world!";
+   Y : AF := X (7 .. 12)'Unrestricted_Access;
 
 begin
-   P (X(7 .. 12)'Unrestricted_Access);
+   P (A (Y));
 end;
 @end smallexample
 
 @noindent
-This inevitably raises @code{Program_Error}.
 A normal unconstrained array value
 or a constrained array object marked as aliased has the bounds in memory
 just before the array, so a thin pointer can retrieve both the data and
-the bounds. But in this case, the non-aliased object @code{X} does not have the
-bounds before the string. If the size clause for type @code{A}
+the bounds.  But in this case, the non-aliased object @code{X} does not have the
+bounds before the string.  If the size clause for type @code{A}
 were not present, then the pointer
 would be a fat pointer, where one component is a pointer to the bounds,
-and all would be well. But with the size clause present, the conversion from
-fat pointer to think pointer in the call looses the bounds.
+and all would be well.  But with the size clause present, the conversion from
+fat pointer to thin pointer in the call looses the bounds, and so this
+program raises a @code{Program_Error} exception if executed.
 
 In general, it is advisable to completely
 avoid mixing the use of thin pointers and the use of
 @code{Unrestricted_Access} where the designated type is an
-unconstrained array. The use of thin pointers should be restricted to
+unconstrained array.  The use of thin pointers should be restricted to
 cases of porting legacy code which implicitly assumes the size of pointers,
 and such code should not in any case be using this attribute.
 
Index: sinfo.adb
===================================================================
--- sinfo.adb	(revision 212640)
+++ sinfo.adb	(working copy)
@@ -2338,6 +2338,14 @@ 
       return Flag17 (N);
    end No_Truncation;
 
+   function Non_Aliased_Prefix
+     (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference);
+      return Flag18 (N);
+   end Non_Aliased_Prefix;
+
    function Null_Present
       (N : Node_Id) return Boolean is
    begin
@@ -5487,6 +5495,14 @@ 
       Set_Flag17 (N, Val);
    end Set_No_Truncation;
 
+   procedure Set_Non_Aliased_Prefix
+     (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference);
+      Set_Flag18 (N, Val);
+   end Set_Non_Aliased_Prefix;
+
    procedure Set_Null_Present
       (N : Node_Id; Val : Boolean := True) is
    begin
Index: sinfo.ads
===================================================================
--- sinfo.ads	(revision 212640)
+++ sinfo.ads	(working copy)
@@ -1809,6 +1809,13 @@ 
    --    is used for properly setting out of range values for use by pragmas
    --    Initialize_Scalars and Normalize_Scalars.
 
+   --  Non_Aliased_Prefix (Flag18-Sem)
+   --    Present in N_Attribute_Reference nodes. Set only for the case of an
+   --    Unrestricted_Access reference whose prefix is non-aliased, which is
+   --    the case that is permitted for Unrestricted_Access except when the
+   --    expected type is a thin pointer to unconstrained array. This flag is
+   --    to assist in detecting this illegal use of Unrestricted_Access.
+
    --  Original_Discriminant (Node2-Sem)
    --    Present in identifiers. Used in references to discriminants that
    --    appear in generic units. Because the names of the discriminants may be
@@ -3621,8 +3628,10 @@ 
       --  Associated_Node (Node4-Sem)
       --  Do_Overflow_Check (Flag17-Sem)
       --  Header_Size_Added (Flag11-Sem)
+      --  Must_Be_Byte_Aligned (Flag14-Sem)
+      --  Non_Aliased_Prefix (Flag18-Sem)
       --  Redundant_Use (Flag13-Sem)
-      --  Must_Be_Byte_Aligned (Flag14)
+
       --  plus fields for expression
 
       --  Note: in Modify_Tree_For_C mode, Max and Min attributes are expanded
@@ -9242,6 +9251,9 @@ 
    function No_Truncation
      (N : Node_Id) return Boolean;    -- Flag17
 
+   function Non_Aliased_Prefix
+     (N : Node_Id) return Boolean;    -- Flag18
+
    function Null_Present
      (N : Node_Id) return Boolean;    -- Flag13
 
@@ -10244,6 +10256,9 @@ 
    procedure Set_No_Truncation
      (N : Node_Id; Val : Boolean := True);    -- Flag17
 
+   procedure Set_Non_Aliased_Prefix
+     (N : Node_Id; Val : Boolean := True);    -- Flag18
+
    procedure Set_Null_Present
      (N : Node_Id; Val : Boolean := True);    -- Flag13
 
@@ -12510,6 +12525,7 @@ 
    pragma Inline (No_Initialization);
    pragma Inline (No_Minimize_Eliminate);
    pragma Inline (No_Truncation);
+   pragma Inline (Non_Aliased_Prefix);
    pragma Inline (Null_Present);
    pragma Inline (Null_Exclusion_Present);
    pragma Inline (Null_Exclusion_In_Return_Present);
@@ -12840,6 +12856,7 @@ 
    pragma Inline (Set_No_Initialization);
    pragma Inline (Set_No_Minimize_Eliminate);
    pragma Inline (Set_No_Truncation);
+   pragma Inline (Set_Non_Aliased_Prefix);
    pragma Inline (Set_Null_Exclusion_Present);
    pragma Inline (Set_Null_Exclusion_In_Return_Present);
    pragma Inline (Set_Null_Present);
Index: sem_attr.adb
===================================================================
--- sem_attr.adb	(revision 212649)
+++ sem_attr.adb	(working copy)
@@ -764,9 +764,7 @@ 
 
          --  Case of access to subprogram
 
-         if Is_Entity_Name (P)
-           and then Is_Overloadable (Entity (P))
-         then
+         if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then
             if Has_Pragma_Inline_Always (Entity (P)) then
                Error_Attr_P
                  ("prefix of % attribute cannot be Inline_Always subprogram");
@@ -961,15 +959,17 @@ 
             end if;
          end if;
 
-         --  If we fall through, we have a normal access to object case.
-         --  Unrestricted_Access is legal wherever an allocator would be
-         --  legal, so its Etype is set to E_Allocator. The expected type
+         --  If we fall through, we have a normal access to object case
+
+         --  Unrestricted_Access is (for now) legal wherever an allocator would
+         --  be legal, so its Etype is set to E_Allocator. The expected type
          --  of the other attributes is a general access type, and therefore
          --  we label them with E_Access_Attribute_Type.
 
          if not Is_Overloaded (P) then
             Acc_Type := Build_Access_Object_Type (P_Type);
             Set_Etype (N, Acc_Type);
+
          else
             declare
                Index : Interp_Index;
@@ -1022,21 +1022,42 @@ 
             end loop;
          end;
 
-         --  Check for aliased view unless unrestricted case. We allow a
-         --  nonaliased prefix when within an instance because the prefix may
-         --  have been a tagged formal object, which is defined to be aliased
-         --  even when the actual might not be (other instance cases will have
-         --  been caught in the generic). Similarly, within an inlined body we
-         --  know that the attribute is legal in the original subprogram, and
-         --  therefore legal in the expansion.
+         --  Check for aliased view.. We allow a nonaliased prefix when within
+         --  an instance because the prefix may have been a tagged formal
+         --  object, which is defined to be aliased even when the actual
+         --  might not be (other instance cases will have been caught in the
+         --  generic). Similarly, within an inlined body we know that the
+         --  attribute is legal in the original subprogram, and therefore
+         --  legal in the expansion.
 
-         if Aname /= Name_Unrestricted_Access
-           and then not Is_Aliased_View (P)
+         if not Is_Aliased_View (P)
            and then not In_Instance
            and then not In_Inlined_Body
          then
-            Error_Attr_P ("prefix of % attribute must be aliased");
-            Check_No_Implicit_Aliasing (P);
+            --  Here we have a non-aliased view. This is illegal unless we
+            --  have the case of Unrestricted_Access, where for now we allow
+            --  this (we will reject later if expected type is access to an
+            --  unconstrained array with a thin pointer).
+
+            if Aname /= Name_Unrestricted_Access then
+               Error_Attr_P ("prefix of % attribute must be aliased");
+               Check_No_Implicit_Aliasing (P);
+
+            --  For Unrestricted_Access, record that prefix is not aliased
+            --  to simplify legality check later on.
+
+            else
+               Set_Non_Aliased_Prefix (N);
+            end if;
+
+         --  If we have an aliased view, and we have Unrestricted_Access, then
+         --  output a warning that Unchecked_Access would have been fine, and
+         --  change the node to be Unchecked_Access.
+
+         else
+            --  For now, hold off on this change ???
+
+            null;
          end if;
       end Analyze_Access_Attribute;
 
@@ -9726,10 +9747,10 @@ 
                Note_Possible_Modification (P, Sure => False);
             end if;
 
-            --  The following comes from a query by Adam Beneschan, concerning
-            --  improper use of universal_access in equality tests involving
-            --  anonymous access types. Another good reason for 'Ref, but
-            --  for now disable the test, which breaks several filed tests.
+            --  The following comes from a query concerning improper use of
+            --  universal_access in equality tests involving anonymous access
+            --  types. Another good reason for 'Ref, but for now disable the
+            --  test, which breaks several filed tests???
 
             if Ekind (Typ) = E_Anonymous_Access_Type
               and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne)
@@ -9739,7 +9760,12 @@ 
                Error_Msg_N ("\qualify attribute with some access type", N);
             end if;
 
+            --  Case where prefix is an entity name
+
             if Is_Entity_Name (P) then
+
+               --  Deal with case where prefix itself is overloaded
+
                if Is_Overloaded (P) then
                   Get_First_Interp (P, Index, It);
                   while Present (It.Nam) loop
@@ -9772,12 +9798,19 @@ 
                      Freeze_Before (N, Entity (P));
                   end if;
 
+               --  Nothing to do if prefix is a type name
+
                elsif Is_Type (Entity (P)) then
                   null;
+
+               --  Otherwise non-overloaded other case, resolve the prefix
+
                else
                   Resolve (P);
                end if;
 
+               --  Some further error checks
+
                Error_Msg_Name_1 := Aname;
 
                if not Is_Entity_Name (P) then
@@ -10109,7 +10142,7 @@ 
                   or else
                 Attr_Id = Attribute_Unchecked_Access)
               and then (Ekind (Btyp) = E_General_Access_Type
-                          or else Ekind (Btyp) = E_Anonymous_Access_Type)
+                         or else Ekind (Btyp) = E_Anonymous_Access_Type)
             then
                --  Ada 2005 (AI-230): Check the accessibility of anonymous
                --  access types for stand-alone objects, record and array
@@ -10358,6 +10391,28 @@ 
                end if;
             end if;
 
+            --  Check for unrestricted access where expected type is a thin
+            --  pointer to an unconstrained array.
+
+            if Non_Aliased_Prefix (N)
+              and then 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;
+            end if;
+
+            --  Mark that address of entity is taken
+
             if Is_Entity_Name (P) then
                Set_Address_Taken (Entity (P));
             end if;