public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-386] [Ada] Spurious access error in function returning type with access discriminant
@ 2022-05-13 8:07 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-05-13 8:07 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:fa45988cc0129f95d1c8b1d386342b6351233ef5
commit r13-386-gfa45988cc0129f95d1c8b1d386342b6351233ef5
Author: Justin Squirek <squirek@adacore.com>
Date: Wed Dec 15 14:27:23 2021 +0000
[Ada] Spurious access error in function returning type with access discriminant
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.
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:
---
gcc/ada/sem_ch6.adb | 69 +++++++++++++++++++++++++++++++++++++++++++---------
gcc/ada/sem_util.adb | 55 ++++++++++++++++++++++++++---------------
gcc/ada/sem_util.ads | 4 +--
3 files changed, 94 insertions(+), 34 deletions(-)
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 92e48fa413b..17e7d262534 100644
--- 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
index f12dbc7a120..e2a49632413 100644
--- 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
index 4ab40164c65..e5e1d01c905 100644
--- 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,
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-13 8:07 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-13 8:07 [gcc r13-386] [Ada] Spurious access error in function returning type with access discriminant Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).