This patch fixes a bug in the compiler whereby a local object of a named
access type used as an actual for an anonymous access discriminant
within a return aggregate would lead to an incorrect accessibility level
calculation and thus an incorrect compile-time accessibility error on
such an object.
Tested on x86_64-pc-linux-gnu, committed on trunk
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
--- 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
--- 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
--- 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
--- 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. ???)
