https://gcc.gnu.org/g:d90a3d5e91baffcfea1797d5283542857750a617
commit r17-1309-gd90a3d5e91baffcfea1797d5283542857750a617 Author: Eric Botcazou <[email protected]> Date: Thu May 14 11:43:21 2026 +0200 ada: Fix missing error for too deep access result in generic function The problem is that, unlike in the nongeneric case, the analysis of the access result definition in the generic function specification does not cause Is_Local_Anonymous_Access to be set on the anonymous access type created for the result. The fix exposes a loophole in the calculation of the accessibility level for formal objects of generic subprograms, as well as two illegal cases in the GNAT.CPP_Exceptions unit of the run-time library. gcc/ada/ChangeLog: * accessibility.ads: Alphabetize declarations. (Subprogram_Access_Level): Beef up description. * accessibility.adb (Accessibility_Level): Deal with formal objects of generic subprograms. * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Set the Is_Local_Anonymous_Access flag on the access result type, if any. * libgnat/g-cppexc.ads (Get_Access_To_Tagged_Object): Do not declare the formal type parameter as abstract. * libgnat/g-cppexc.adb (Get_Access_To_Object): Fix illegal code. (Get_Access_To_Tagged_Object): Likewise. Diff: --- gcc/ada/accessibility.adb | 11 ++++++++--- gcc/ada/accessibility.ads | 46 ++++++++++++++++++++++++-------------------- gcc/ada/libgnat/g-cppexc.adb | 22 ++++++++------------- gcc/ada/libgnat/g-cppexc.ads | 2 +- gcc/ada/sem_ch12.adb | 2 ++ 5 files changed, 44 insertions(+), 39 deletions(-) diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index 52d4810987f6..f29e846a98e0 100644 --- a/gcc/ada/accessibility.adb +++ b/gcc/ada/accessibility.adb @@ -715,8 +715,7 @@ package body Accessibility is -- Return the dynamic level in the normal case - return New_Occurrence_Of - (Get_Dynamic_Accessibility (E), Loc); + return New_Occurrence_Of (Get_Dynamic_Accessibility (E), Loc); -- Initialization procedures have a special extra accessibility -- parameter associated with the level at which the object @@ -782,7 +781,13 @@ package body Accessibility is return New_Occurrence_Of (Init_Proc_Level_Formal (Scope (E)), Loc); - -- Normal object - get the level of the enclosing scope + -- Formal object of generic subprogram - get the level of the + -- subprogram + + elsif Is_Formal_Object (E) and then Is_Subprogram (Scope (E)) then + return Make_Level_Literal (Subprogram_Access_Level (Scope (E))); + + -- Normal object - get the depth of the enclosing dynamic scope else return Make_Level_Literal diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads index d339caf3ea8b..552074e085d8 100644 --- a/gcc/ada/accessibility.ads +++ b/gcc/ada/accessibility.ads @@ -154,6 +154,26 @@ package Accessibility is function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean; -- Returns True if Typ has one or more anonymous access discriminants + function Has_Unconstrained_Access_Discriminants + (Subtyp : Entity_Id) return Boolean; + -- Returns True if the given subtype is unconstrained and has one or more + -- access discriminants. + + function Needs_Accessibility_Level_Temp_Or_Check + (Conditional_Expr : Node_Id) return Boolean; + -- Determine whether a conditional expression occurs in a context that + -- requires either an associated accessibility-level-valued temp (which + -- is assigned to in each arm of the conditional expression) or an + -- accessibility level check (which is pushed down into each arm of the + -- conditional expression). + + function Needs_Result_Accessibility_Level + (Func_Id : Entity_Id) return Boolean; + -- Ada 2012 (AI05-0234): Return True if the function needs an implicit + -- parameter to identify the accessibility level of the function result + -- "determined by the point of call". Return False if the type of the + -- function result is a private type and its completion is unavailable. + function Prefix_With_Safe_Accessibility_Level (N : Node_Id; Typ : Entity_Id) return Boolean; @@ -177,28 +197,12 @@ package Accessibility is -- integer for use in compile-time checking. Note: Level is restricted to -- be non-dynamic. - function Has_Unconstrained_Access_Discriminants - (Subtyp : Entity_Id) return Boolean; - -- Returns True if the given subtype is unconstrained and has one or more - -- access discriminants. - - function Needs_Accessibility_Level_Temp_Or_Check - (Conditional_Expr : Node_Id) return Boolean; - -- Determine whether a conditional expression occurs in a context that - -- requires either an associated accessibility-level-valued temp (which - -- is assigned to in each arm of the conditional expression) or an - -- accessibility level check (which is pushed down into each arm of the - -- conditional expression). - - function Needs_Result_Accessibility_Level - (Func_Id : Entity_Id) return Boolean; - -- Ada 2012 (AI05-0234): Return True if the function needs an implicit - -- parameter to identify the accessibility level of the function result - -- "determined by the point of call". Return False if the type of the - -- function result is a private type and its completion is unavailable. - function Subprogram_Access_Level (Subp : Entity_Id) return Uint; - -- Return the accessibility level of the view denoted by Subp + -- Return the accessibility level of Subp. Note that this is the level of + -- the innermost master of the declaration of Subp (modulo renaming) and, + -- in particular, is *not* the level of the entities declared within Subp. + -- It is used to enforce the accessibility rules for access-to-subprogram + -- types, results of function calls, and formal objects of generic units. function Type_Access_Level (Typ : Entity_Id; diff --git a/gcc/ada/libgnat/g-cppexc.adb b/gcc/ada/libgnat/g-cppexc.adb index 1522cde6ffa2..20ec8df0a284 100644 --- a/gcc/ada/libgnat/g-cppexc.adb +++ b/gcc/ada/libgnat/g-cppexc.adb @@ -176,15 +176,12 @@ package body GNAT.CPP_Exceptions is Object_Addr : constant System.Address := Get_Object_Address (X); -- Address of the raised object - type T_Acc is access T; - - function To_T_Acc is - new Ada.Unchecked_Conversion (System.Address, T_Acc); - -- Import the object from the occurrence - Result : constant T_Acc := To_T_Acc (Object_Addr); + Result : aliased T; + pragma Import (Ada, Result); + for Result'Address use Object_Addr; begin - return Result; + return Result'Unchecked_Access; end Get_Access_To_Object; --------------------------------- @@ -197,15 +194,12 @@ package body GNAT.CPP_Exceptions is Object_Addr : constant System.Address := Get_Object_Address (X); -- Address of the raised object - type T_Acc is access T'Class; - - function To_T_Acc is - new Ada.Unchecked_Conversion (System.Address, T_Acc); - -- Import the object from the occurrence - Result : constant T_Acc := To_T_Acc (Object_Addr); + Result : aliased T; + pragma Import (Ada, Result); + for Result'Address use Object_Addr; begin - return Result; + return Result'Unchecked_Access; end Get_Access_To_Tagged_Object; ------------------- diff --git a/gcc/ada/libgnat/g-cppexc.ads b/gcc/ada/libgnat/g-cppexc.ads index 41048e2ef7ce..b20f5eac1172 100644 --- a/gcc/ada/libgnat/g-cppexc.ads +++ b/gcc/ada/libgnat/g-cppexc.ads @@ -69,7 +69,7 @@ package GNAT.CPP_Exceptions is -- explicitly expected by the handler. generic - type T is abstract tagged limited private; + type T is tagged limited private; function Get_Access_To_Tagged_Object (X : Exception_Occurrence) return access T'Class; -- Extract the object associated with X. The exception of the diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index ebdc9ba36706..600e3f055b1b 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -4745,6 +4745,8 @@ package body Sem_Ch12 is if Nkind (Spec) = N_Function_Specification then if Nkind (Result_Definition (Spec)) = N_Access_Definition then Result_Type := Access_Definition (Spec, Result_Definition (Spec)); + Set_Parent (Result_Type, Result_Definition (Spec)); + Set_Is_Local_Anonymous_Access (Result_Type); Set_Etype (Id, Result_Type); -- Check restriction imposed by AI05-073: a generic function
