https://gcc.gnu.org/g:7572d87ed24737dc7c84c10de4431caf6a9c2d9b
commit r16-2464-g7572d87ed24737dc7c84c10de4431caf6a9c2d9b
Author: Steve Baird <ba...@adacore.com>
Date: Mon Mar 24 15:34:34 2025 -0700
ada: Function return accessibility checking for result access discrims.
RM 6.5 defines static and dynamic checks to ensure that a function result
with one or more access discriminants will not outlive the entity
designated by a non-null access discriminant value (see paragraphs
5.9 and 21). Implement these checks. Also fix a bug in passing along
an implicit parameter needed to perform the dynamic checks when a function
that takes such a parameter returns a call to another such function.
gcc/ada/ChangeLog:
* accessibility.adb (Function_Call_Or_Allocator_Level): Handle the
case where a function that has an Extra_Accessibility_Of_Result
parameter returns as its result a call to another such function.
In that case, the extra parameter should be passed along.
(Check_Return_Construct_Accessibility): Replace a warning about an
inevitable failure of a dynamic check with a legality-rule-violation
error message; adjust the text of the message accordingly.
* exp_ch6.ads (Apply_Access_Discrims_Accessibility_Check): New
procedure, following example of the existing
Apply_CW_Accessibility procedure.
* exp_ch6.adb (Apply_Access_Discrims_Accessibility_Check): body
for new procedure.
(Expand_Simple_Function_Return): Add call to new
Apply_Access_Discrims_Accessibility_Check procedure.
* exp_ch3.adb (Make_Allocator_For_Return): Add call to new
Apply_Access_Discrims_Accessibility_Check procedure.
Diff:
---
gcc/ada/accessibility.adb | 27 ++++--
gcc/ada/exp_ch3.adb | 10 ++
gcc/ada/exp_ch6.adb | 241 ++++++++++++++++++++++++++++++++++++++++++++++
gcc/ada/exp_ch6.ads | 9 ++
4 files changed, 280 insertions(+), 7 deletions(-)
diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index 0b8d3f7746d7..c7800542dccb 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -327,8 +327,23 @@ package body Accessibility is
if In_Return_Value (N)
or else In_Return_Context
then
- return Make_Level_Literal
- (Subprogram_Access_Level (Current_Subprogram));
+ if Present (Extra_Accessibility_Of_Result
+ (Current_Subprogram))
+ then
+ -- If a function is passed an extra "level of the
+ -- master of the call" parameter and that function
+ -- returns a call to another such function (or
+ -- possibly to the same function, in the case of a
+ -- recursive call), then that parameter should be
+ -- "passed along".
+
+ return New_Occurrence_Of
+ (Extra_Accessibility_Of_Result
+ (Current_Subprogram), Loc);
+ else
+ return Make_Level_Literal
+ (Subprogram_Access_Level (Current_Subprogram));
+ end if;
end if;
end if;
@@ -1683,16 +1698,14 @@ package body Accessibility is
Condition => Check_Cond,
Reason => PE_Accessibility_Check_Failed));
- -- If constant folding has happened on the condition for the
- -- generated error, then warn about it being unconditional when
- -- we know an error will be raised.
+ -- ??? Is this how we want to detect RM 6.5(5.9) violations?
if Nkind (Check_Cond) = N_Identifier
and then Entity (Check_Cond) = Standard_True
then
Error_Msg_N
- ("access discriminant in return object could be a dangling"
- & " reference??", Return_Stmt);
+ ("level of type of access discriminant value of return object"
+ & " is statically too deep", Return_Stmt);
end if;
end if;
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 5bb4a25a715a..6cf7c9c97076 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -7501,6 +7501,12 @@ package body Exp_Ch3 is
Apply_CW_Accessibility_Check (Expr, Func_Id);
end if;
+ if Has_Anonymous_Access_Discriminant (Etype (Expr)) then
+ -- Check that access discrims do not designate entities
+ -- that the function result could outlive.
+ Apply_Access_Discrims_Accessibility_Check (Expr, Func_Id);
+ end if;
+
Alloc_Expr := New_Copy_Tree (Expr);
if Etype (Alloc_Expr) /= Alloc_Typ then
@@ -9059,6 +9065,10 @@ package body Exp_Ch3 is
if Is_Class_Wide_Type (Etype (Func_Id)) then
Apply_CW_Accessibility_Check (Expr_Q, Func_Id);
end if;
+
+ -- ??? Usually calls to Apply_CW_Accessibility_Check and to
+ -- Apply_Access_Discrims_Accessibility_Check come in pairs.
+ -- Do we need a (conditional) call here to A_A_D_A_C ?
end;
end if;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 1195582aaeab..255fa12f8eb5 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -734,6 +734,237 @@ package body Exp_Ch6 is
Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual);
end Add_Task_Actuals_To_Build_In_Place_Call;
+ ----------------------------------------------
+ -- Apply_Access_Discrims_Accesibility_Check --
+ ----------------------------------------------
+
+ procedure Apply_Access_Discrims_Accessibility_Check
+ (Exp : Node_Id; Func : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Exp);
+
+ -- Some of the code here in this procedure may need to be factored
+ -- out at some point because it seems like some of the same
+ -- functionality would be needed for accessibility checking of a
+ -- return statement when the function result type is an anonymous
+ -- access type (as opposed to a type that has an anonymous access
+ -- discriminant).
+ --
+ -- Another case that is not addressed today is the case where
+ -- we need to check an access discriminant subcomponent of the
+ -- function result other than a discriminant of the function result.
+ -- This can only happen if the function result type has an unconstrained
+ -- subcomponent subtype that has an access discriminant (which implies
+ -- that the function result type must be limited).
+ --
+ -- A further corner case of that corner case arises if the limited
+ -- function result type is class-wide and it is not known statically
+ -- that this access-discriminant-bearing subcomponent exists. The
+ -- easiest way to address this properly would probably involve adding
+ -- a new compiler-generated dispatching procedure; a dispatching call
+ -- could then be used to perform the check in a context where we know
+ -- statically the specific type of the function result. Finding a
+ -- less important unimplemented case would be challenging.
+
+ function Constraint_Bearing_Subtype_If_Any
+ (Exp : Node_Id) return Node_Id;
+ -- If we can locate a constrained subtype whose constraint applies
+ -- to Exp, then return that. Otherwise, return Etype (Exp).
+
+ function Discr_Expression
+ (Typ : Entity_Id; Discr_Index : Positive) return Node_Id;
+ -- Typ is a constrained discriminated subtype.
+ -- Return the constraint expression for the indexed discriminant.
+
+ function Has_Level_Tied_To_Explicitly_Aliased_Param
+ (Constraint_Exp : Node_Id) return Boolean;
+ -- Constraint_Exp is the value given for an access discriminant
+ -- in a discriminant constraint for Exp. Return True iff the
+ -- accessibility of the type of that discriminant of Exp is the level
+ -- of an explicitly aliased parameter of Func. If true, this indicates
+ -- that no check should be performed for this discriminant.
+
+ ---------------------------------------
+ -- Constraint_Bearing_Subtype_If_Any --
+ ---------------------------------------
+
+ function Constraint_Bearing_Subtype_If_Any
+ (Exp : Node_Id) return Entity_Id
+ is
+ Result : Entity_Id := Etype (Exp);
+ begin
+ if Is_Constrained (Result) then
+ return Result;
+ end if;
+
+ -- Look through expansion-generated levels of indirection
+ -- to find a constrained subtype. Yuck. This comes up in
+ -- some cases when the unexpanded source returns an aggregate.
+
+ if Nkind (Exp) = N_Explicit_Dereference
+ and then Nkind (Prefix (Exp)) = N_Identifier
+ and then Ekind (Entity (Prefix (Exp))) = E_Constant
+ then
+ declare
+ Acc_Const : Entity_Id := Entity (Prefix (Exp));
+ Acc_Const_Value : Node_Id := Empty;
+ begin
+ -- look through constants initialized to constants
+ loop
+ exit when Nkind (Parent (Acc_Const)) /= N_Object_Declaration;
+
+ Acc_Const_Value := Expression (Parent (Acc_Const));
+
+ if Nkind (Acc_Const_Value) = N_Identifier
+ and then Ekind (Entity (Acc_Const_Value)) = E_Constant
+ then
+ Acc_Const := Entity (Acc_Const_Value);
+ else
+ exit;
+ end if;
+ end loop;
+
+ if Nkind (Acc_Const_Value) = N_Allocator
+ and then Nkind (Expression (Acc_Const_Value))
+ = N_Qualified_Expression
+ then
+ Result :=
+ Etype (Expression (Acc_Const_Value));
+ end if;
+ end;
+ end if;
+
+ if Is_Constrained (Result) then
+ return Result;
+ end if;
+
+ -- no constrained subtype found
+ return Etype (Exp);
+ end Constraint_Bearing_Subtype_If_Any;
+
+ ----------------------
+ -- Discr_Expression --
+ ----------------------
+
+ function Discr_Expression
+ (Typ : Entity_Id; Discr_Index : Positive) return Node_Id
+ is
+ Constraint_Elmt : Elmt_Id :=
+ First_Elmt (Discriminant_Constraint (Typ));
+ begin
+ for Skip in 1 .. Discr_Index - 1 loop
+ Next_Elmt (Constraint_Elmt);
+ end loop;
+ return Node (Constraint_Elmt);
+ end Discr_Expression;
+
+ -------------------------------------------------
+ -- Has_Level_Tied_To_Explicitly_Aliased_Param --
+ -------------------------------------------------
+
+ function Has_Level_Tied_To_Explicitly_Aliased_Param
+ (Constraint_Exp : Node_Id) return Boolean
+ is
+ Discr_Exp : Node_Id := Constraint_Exp;
+ Attr_Prefix : Node_Id;
+ begin
+ -- look through constants
+ while Nkind (Discr_Exp) = N_Identifier
+ and then Ekind (Entity (Discr_Exp)) = E_Constant
+ and then Nkind (Parent (Entity (Discr_Exp))) = N_Object_Declaration
+ loop
+ Discr_Exp := Expression (Parent (Entity (Discr_Exp)));
+ end loop;
+
+ if Nkind (Discr_Exp) = N_Attribute_Reference
+ and then Get_Attribute_Id
+ (Attribute_Name (Discr_Exp)) = Attribute_Access
+ then
+ Attr_Prefix := Ultimate_Prefix (Prefix (Discr_Exp));
+ if Is_Entity_Name (Attr_Prefix)
+ and then Is_Explicitly_Aliased (Entity (Attr_Prefix))
+ and then Scope (Entity (Attr_Prefix)) = Func
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Has_Level_Tied_To_Explicitly_Aliased_Param;
+
+ Discr : Entity_Id := First_Discriminant (Etype (Exp));
+ Discr_Index : Positive := 1;
+ Discr_Exp : Node_Id;
+
+ Constrained_Subtype : constant Entity_Id :=
+ Constraint_Bearing_Subtype_If_Any (Exp);
+ begin
+ -- If we are returning a function call then that function will
+ -- perform the needed check.
+
+ if Nkind (Unqualify (Exp)) = N_Function_Call then
+ return;
+ end if;
+
+ Remove_Side_Effects (Exp);
+
+ while Present (Discr) loop
+ if Is_Anonymous_Access_Type (Etype (Discr)) then
+ if Is_Constrained (Constrained_Subtype) then
+ Discr_Exp :=
+ New_Copy_Tree
+ (Discr_Expression (Constrained_Subtype, Discr_Index));
+ else
+ Discr_Exp :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Exp),
+ Selector_Name => New_Occurrence_Of (Discr, Loc));
+ end if;
+
+ if not Has_Level_Tied_To_Explicitly_Aliased_Param (Discr_Exp) then
+ declare
+ -- We could do this min operation earlier, as is done
+ -- for other implicit level parameters. Motivation for
+ -- doing this min operation (earlier or not) is as for
+ -- Generate_Minimum_Accessibility (see sem_ch6.adb):
+ -- if a level value is too big, then the caller and the
+ -- callee disagree about what it means.
+
+ Level_Of_Master_Of_Call : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Standard_Natural, Loc),
+ Attribute_Name => Name_Min,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Scope_Depth (Func)),
+ New_Occurrence_Of
+ (Extra_Accessibility_Of_Result (Func), Loc)));
+
+ Discrim_Level : Node_Id;
+ begin
+ Analyze (Level_Of_Master_Of_Call);
+ Analyze (Discr_Exp);
+
+ Discrim_Level :=
+ Accessibility_Level (Discr_Exp, Level => Dynamic_Level);
+ Analyze (Discrim_Level);
+
+ Insert_Action (Exp,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Discrim_Level,
+ Right_Opnd => Level_Of_Master_Of_Call),
+ Reason => PE_Accessibility_Check_Failed),
+ Suppress => Access_Check);
+ end;
+ end if;
+ end if;
+
+ Next_Discriminant (Discr);
+ Discr_Index := Discr_Index + 1;
+ end loop;
+ end Apply_Access_Discrims_Accessibility_Check;
+
----------------------------------
-- Apply_CW_Accessibility_Check --
----------------------------------
@@ -7317,6 +7548,16 @@ package body Exp_Ch6 is
then
Apply_CW_Accessibility_Check (Exp, Scope_Id);
+ -- Check that result's access discrims (if any) do not designate
+ -- entities that the function result could outlive. See preceding
+ -- comment about extended return statements and thunks.
+
+ elsif Has_Anonymous_Access_Discriminant (Exp_Typ)
+ and then not Comes_From_Extended_Return_Statement (N)
+ and then not Is_Thunk (Scope_Id)
+ then
+ Apply_Access_Discrims_Accessibility_Check (Exp, Scope_Id);
+
-- Ada 2012 (AI05-0073): If the result subtype of the function is
-- defined by an access_definition designating a specific tagged
-- type T, a check is made that the result value is null or the tag
diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index 483b78bd1781..5919627a4e7e 100644
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -105,7 +105,16 @@ package Exp_Ch6 is
-- Create the extra actuals of the given call and add them to its
-- actual parameters list.
+ procedure Apply_Access_Discrims_Accessibility_Check
+ (Exp : Node_Id; Func : Entity_Id);
+ -- Exp is an expression being returned from a function Func.
+ -- If the result type of the function has access discriminants, insert
+ -- checks that the accessibility level of each entity designated by an
+ -- access discriminant of the result is not deeper than the level of the
+ -- master of the call.
+
procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id);
+ -- Exp is an expression being returned from a function Func.
-- Ada 2005 (AI95-344): If the result type is class-wide, insert a check
-- that the level of the return expression's underlying type is not deeper
-- than the level of the master enclosing the function. Always generate the
