From: Eric Botcazou Date: Thu, 14 May 2026 09:43:21 +0000 (+0200) Subject: ada: Fix missing error for too deep access result in generic function X-Git-Url: http://git.ipfire.org/gitweb/index.cgi?a=commitdiff_plain;h=d90a3d5e91baffcfea1797d5283542857750a617;p=thirdparty%2Fgcc.git 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 --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index 52d4810987f..f29e846a98e 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 d339caf3ea8..552074e085d 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 1522cde6ffa..20ec8df0a28 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 41048e2ef7c..b20f5eac117 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 ebdc9ba3670..600e3f055b1 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