This patch fixes an issue in the compiler whereby incorrect
accessibility checks were generated in functions returning types with
unconstrained access discriminants when the value supplied for the
discriminant is a formal parameter.
More specifically, accessibility checks for return statements featuring
a result type having access discriminants were incorrectly being
performed against the level of the function declaration instead of the
level of the master of the call.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_ch6.adb (Check_Return_Construct_Accessibility): Modify
generation of run-time accessibility checks to account for cases
where Extra_Accessibility_Of_Result should be used versus the
level of the enclosing subprogram. Use original node to avoid
checking against expanded code. Disable check generation for
tagged type case.
(Is_Formal_Of_Current_Function): Added to encompass a predicate
used within Check_Return_Construct_Accessibility to test if an
associated expression is related to a relevant formal.
* sem_util.adb, sem_util.ads (Enclosing_Subprogram): Modified to
accept Node_Or_Entity_Id.
(Innermost_Master_Scope_Depth): Calculate level based on the
subprogram of a return statement instead of the one returned by
Current_Subprogram.
(Needs_Result_Accessibility_Level): Remove
Disable_Coextension_Cases constant, and disable the tagged type
case for performance reasons.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
@@ -777,6 +777,12 @@ package body Sem_Ch6 is
function First_Selector (Assoc : Node_Id) return Node_Id;
-- Obtain the first selector or choice from a given association
+ function Is_Formal_Of_Current_Function
+ (Assoc_Expr : Entity_Id) return Boolean;
+ -- Predicate to test if a given expression associated with a
+ -- discriminant is a formal parameter to the function in which the
+ -- return construct we checking applies to.
+
--------------------
-- First_Selector --
--------------------
@@ -794,6 +800,19 @@ package body Sem_Ch6 is
end if;
end First_Selector;
+ -----------------------------------
+ -- Is_Formal_Of_Current_Function --
+ -----------------------------------
+
+ function Is_Formal_Of_Current_Function
+ (Assoc_Expr : Entity_Id) return Boolean is
+ begin
+ return Is_Entity_Name (Assoc_Expr)
+ and then Enclosing_Subprogram
+ (Entity (Assoc_Expr)) = Scope_Id
+ and then Is_Formal (Entity (Assoc_Expr));
+ end Is_Formal_Of_Current_Function;
+
-- Local declarations
Assoc : Node_Id := Empty;
@@ -869,7 +888,10 @@ package body Sem_Ch6 is
-- with all anonymous access discriminants, then generate a
-- dynamic check or static error when relevant.
- Unqual := Unqualify (Original_Node (Return_Con));
+ -- Note the repeated use of Original_Node to avoid checking
+ -- expanded code.
+
+ Unqual := Original_Node (Unqualify (Original_Node (Return_Con)));
-- Get the corresponding declaration based on the return object's
-- identifier.
@@ -1052,8 +1074,6 @@ package body Sem_Ch6 is
if Nkind (Assoc) = N_Component_Association
and then Box_Present (Assoc)
then
- Assoc_Present := False;
-
if Nkind (First_Selector (Assoc)) = N_Others_Choice then
Unseen_Disc_Count := 0;
end if;
@@ -1178,9 +1198,24 @@ package body Sem_Ch6 is
if Present (Assoc_Expr)
and then Present (Disc)
and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type
+
+ -- We disable the check when we have a tagged return type and
+ -- the associated expression for the discriminant is a formal
+ -- parameter since the check would require us to compare the
+ -- accessibility level of Assoc_Expr to the level of the
+ -- Extra_Accessibility_Of_Result of the function - which is
+ -- currently disabled for functions with tagged return types.
+ -- This may change in the future ???
+
+ -- See Needs_Result_Accessibility_Level for details.
+
+ and then not
+ (No (Extra_Accessibility_Of_Result (Scope_Id))
+ and then Is_Formal_Of_Current_Function (Assoc_Expr)
+ and then Is_Tagged_Type (Etype (Scope_Id)))
then
-- Generate a dynamic check based on the extra accessibility of
- -- the result or the scope.
+ -- the result or the scope of the current function.
Check_Cond :=
Make_Op_Gt (Loc,
@@ -1188,14 +1223,24 @@ package body Sem_Ch6 is
(Expr => Assoc_Expr,
Level => Dynamic_Level,
In_Return_Context => True),
- Right_Opnd => (if Present
- (Extra_Accessibility_Of_Result
- (Scope_Id))
- then
- Extra_Accessibility_Of_Result (Scope_Id)
- else
- Make_Integer_Literal
- (Loc, Scope_Depth (Scope (Scope_Id)))));
+ Right_Opnd =>
+ (if Present (Extra_Accessibility_Of_Result (Scope_Id))
+
+ -- When Assoc_Expr is a formal we have to look at the
+ -- extra accessibility-level formal associated with
+ -- the result.
+
+ and then Is_Formal_Of_Current_Function (Assoc_Expr)
+ then
+ New_Occurrence_Of
+ (Extra_Accessibility_Of_Result (Scope_Id), Loc)
+
+ -- Otherwise, we compare the level of Assoc_Expr to the
+ -- scope of the current function.
+
+ else
+ Make_Integer_Literal
+ (Loc, Scope_Depth (Scope (Scope_Id)))));
Insert_Before_And_Analyze (Return_Stmt,
Make_Raise_Program_Error (Loc,
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
@@ -327,9 +327,8 @@ package body Sem_Util is
elsif Nkind (Node_Par) in N_Extended_Return_Statement
| N_Simple_Return_Statement
- and then Ekind (Current_Scope) = E_Function
then
- return Scope_Depth (Current_Scope);
+ return Scope_Depth (Enclosing_Subprogram (Node_Par));
-- Statements are counted as masters
@@ -8356,10 +8355,29 @@ package body Sem_Util is
-- Enclosing_Subprogram --
--------------------------
- function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
- Dyn_Scop : constant Entity_Id := Enclosing_Dynamic_Scope (E);
+ function Enclosing_Subprogram (N : Node_Or_Entity_Id) return Entity_Id is
+ Dyn_Scop : Entity_Id;
+ Encl_Scop : Entity_Id;
begin
+ -- Obtain the enclosing scope when N is a Node_Id - taking care to
+ -- handle the case when the enclosing scope is already a subprogram.
+
+ if Nkind (N) not in N_Entity then
+ Encl_Scop := Find_Enclosing_Scope (N);
+
+ if No (Encl_Scop) then
+ return Empty;
+ elsif Ekind (Encl_Scop) in Subprogram_Kind then
+ return Encl_Scop;
+ end if;
+
+ return Enclosing_Subprogram (Encl_Scop);
+ end if;
+
+ -- When N is already an Entity_Id proceed
+
+ Dyn_Scop := Enclosing_Dynamic_Scope (N);
if Dyn_Scop = Standard_Standard then
return Empty;
@@ -23091,8 +23109,8 @@ package body Sem_Util is
if not Is_Limited_Type (Comp_Typ) then
return False;
- -- Only limited types can have access discriminants with
- -- defaults.
+ -- Only limited types can have access discriminants with
+ -- defaults.
elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then
return True;
@@ -23122,16 +23140,18 @@ package body Sem_Util is
return False;
end Has_Unconstrained_Access_Discriminant_Component;
- Disable_Coextension_Cases : constant Boolean := True;
- -- Flag used to temporarily disable a "True" result for types with
- -- access discriminants and related coextension cases.
+ Disable_Tagged_Cases : constant Boolean := True;
+ -- Flag used to temporarily disable a "True" result for tagged types.
+ -- See comments further below for details.
-- Start of processing for Needs_Result_Accessibility_Level
begin
- -- False if completion unavailable (how does this happen???)
+ -- False if completion unavailable, which can happen when we are
+ -- analyzing an abstract subprogram or if the subprogram has
+ -- delayed freezing.
- if not Present (Func_Typ) then
+ if No (Func_Typ) then
return False;
-- False if not a function, also handle enum-lit renames case
@@ -23164,14 +23184,6 @@ package body Sem_Util is
elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then
return True;
- -- The following cases are related to coextensions and do not fully
- -- cover everything mentioned in RM 3.10.2 (12) ???
-
- -- Temporarily disabled ???
-
- elsif Disable_Coextension_Cases then
- return False;
-
-- In the case of, say, a null tagged record result type, the need for
-- this extra parameter might not be obvious so this function returns
-- True for all tagged types for compatibility reasons.
@@ -23188,8 +23200,11 @@ package body Sem_Util is
-- solve these issues by introducing wrappers, but that is not the
-- approach that was chosen.
+ -- Note: Despite the reasoning noted above, the extra accessibility
+ -- parameter for tagged types is disabled for performance reasons.
+
elsif Is_Tagged_Type (Func_Typ) then
- return True;
+ return not Disable_Tagged_Cases;
elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
return True;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -824,9 +824,9 @@ package Sem_Util is
-- Returns the entity of the package or subprogram enclosing E, if any.
-- Returns Empty if no enclosing package or subprogram.
- function Enclosing_Subprogram (E : Entity_Id) return Entity_Id;
+ function Enclosing_Subprogram (N : Node_Or_Entity_Id) return Entity_Id;
-- Utility function to return the Ada entity of the subprogram enclosing
- -- the entity E, if any. Returns Empty if no enclosing subprogram.
+ -- N, if any. Returns Empty if no enclosing subprogram.
function End_Keyword_Location (N : Node_Id) return Source_Ptr;
-- Given block statement, entry body, package body, package declaration,
