[Ada] Incorrect static accessibility error in return aggregate

gcc/ada/

	* einfo.adb, einfo.ads (Is_Named_Access_Type): Created for
	readability.
	* sem_ch6.adb (Check_Return_Construct_Accessibility): Add
	special cases for formals.
	* sem_util.adb (Object_Access_Level): Add handling of access
	attributes and named access types in the general case.

diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 8650542..eab06ee 100644 (file)
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -3797,6 +3797,12 @@ package body Einfo is
       return Ekind (Id) in Modular_Integer_Kind;
    end Is_Modular_Integer_Type;
 
+   function Is_Named_Access_Type                (Id : E) return B is
+   begin
+      return Ekind (Id) in E_Access_Type ..
+                             E_Access_Protected_Subprogram_Type;
+   end Is_Named_Access_Type;
+
    function Is_Named_Number                     (Id : E) return B is
    begin
       return Ekind (Id) in Named_Kind;

diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index bea4db0..758aef5 100644 (file)
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -7624,6 +7624,7 @@ package Einfo is
    function Is_Integer_Type                     (Id : E) return B;
    function Is_Limited_Record                   (Id : E) return B;
    function Is_Modular_Integer_Type             (Id : E) return B;
+   function Is_Named_Access_Type                (Id : E) return B;
    function Is_Named_Number                     (Id : E) return B;
    function Is_Numeric_Type                     (Id : E) return B;
    function Is_Object                           (Id : E) return B;

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 11e496a..1988684 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -904,6 +904,11 @@ package body Sem_Ch6 is
                   --  named access types and renamed objects within the
                   --  expression.
 
+                  --  Note, this loop duplicates some of the logic in
+                  --  Object_Access_Level since we have to check special rules
+                  --  based on the context we are in (a return aggregate)
+                  --  relating to formals of the current function.
+
                   Obj := Original_Node (Prefix (Expr));
                   loop
                      while Nkind_In (Obj, N_Explicit_Dereference,
@@ -943,15 +948,20 @@ package body Sem_Ch6 is
                      end if;
                   end loop;
 
-                  --  Do not check aliased formals or function calls. A
-                  --  run-time check may still be needed ???
+                  --  Do not check aliased formals statically
 
                   if Is_Formal (Entity (Obj))
-                    and then Is_Aliased (Entity (Obj))
+                    and then (Is_Aliased (Entity (Obj))
+                               or else Ekind (Etype (Entity (Obj))) =
+                                         E_Anonymous_Access_Type)
                   then
                      null;
 
-                  elsif Object_Access_Level (Obj) >
+                  --  Otherwise, handle the expression normally, avoiding the
+                  --  special logic above, and call Object_Access_Level with
+                  --  the original expression.
+
+                  elsif Object_Access_Level (Expr) >
                           Scope_Depth (Scope (Scope_Id))
                   then
                      Error_Msg_N

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 228cca2..2ce22e9 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -24330,7 +24330,7 @@ package body Sem_Util is
          --  than the level of any visible named access type (see 3.10.2(21)).
 
          if Is_Type (E) then
-            return Type_Access_Level (E) +  1;
+            return Type_Access_Level (E) + 1;
 
          elsif Present (Renamed_Object (E)) then
             return Object_Access_Level (Renamed_Object (E));
@@ -24347,6 +24347,12 @@ package body Sem_Util is
          then
             return Type_Access_Level (Scope (E)) + 1;
 
+         --  An object of a named access type gets its level from its
+         --  associated type.
+
+         elsif Is_Named_Access_Type (Etype (E)) then
+            return Type_Access_Level (Etype (E));
+
          else
             return Scope_Depth (Enclosing_Dynamic_Scope (E));
          end if;
@@ -24559,6 +24565,15 @@ package body Sem_Util is
       then
          return Object_Access_Level (Current_Scope);
 
+      --  Move up the attribute reference when we encounter a 'Access variation
+
+      elsif Nkind (Orig_Obj) = N_Attribute_Reference
+        and then Nam_In (Attribute_Name (Orig_Obj), Name_Access,
+                                                    Name_Unchecked_Access,
+                                                    Name_Unrestricted_Access)
+      then
+         return Object_Access_Level (Prefix (Orig_Obj));
+
       --  Otherwise return the scope level of Standard. (If there are cases
       --  that fall through to this point they will be treated as having
       --  global accessibility for now. ???)