From 25b4c873d19ccdc7e9a333eab8b5ab8e29a35976 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Fri, 22 May 2020 16:25:00 -0400 Subject: [PATCH] [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. --- gcc/ada/einfo.adb | 6 ++++++ gcc/ada/einfo.ads | 1 + gcc/ada/sem_ch6.adb | 18 ++++++++++++++---- gcc/ada/sem_util.adb | 17 ++++++++++++++++- 4 files changed, 37 insertions(+), 5 deletions(-) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 86505422f8a..eab06eefe49 100644 --- 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 bea4db02471..758aef56576 100644 --- 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 11e496ac804..1988684b674 100644 --- 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 228cca21711..2ce22e988fb 100644 --- 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. ???) -- 2.30.2