From: Eric Botcazou <[email protected]>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
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 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
--
2.53.0
