From: Eric Botcazou <[email protected]>
This implements the last part of the RM 4.8(10.1) rule about allocators
for types with access discriminants. The implementation is modeled on
that of returns for types with access discriminants, given that the set
of rules applying to them is the same (RM 3.10.2(12-12.4)).
The change also streamlines the latter by applying the RM 3.10.2(12.4)
rule in Apply_Accessibility_Check_For_Discriminated_Return.
gcc/ada/ChangeLog:
* accessibility.ads (Apply_Accessibility_Check_For_Allocator):
Rename to...
(Apply_Accessibility_Check_For_Class_Wide_Allocator): ...this.
(Apply_Accessibility_Check_For_Discriminated_Allocator): New.
* accessibility.adb (Apply_Accessibility_Check_For_Allocator):
Rename to...
(Apply_Accessibility_Check_For_Class_Wide_Allocator): ...this.
Call Duplicate_Subexpr directly instead of reimplementing it.
(Apply_Accessibility_Check_For_Discriminated_Allocator): New.
(Apply_Accessibility_Check_For_Discriminated_Return): Streamline.
(Apply_Accessibility_Check_For_Return): Tweak comments.
* exp_ch4.adb (Expand_Allocator_Expression): Call
Apply_Accessibility_Check_For_Discriminated_Allocator and
adjust calls to Apply_Accessibility_Check_For_Allocator.
(Expand_N_Allocator): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/accessibility.adb | 194 +++++++++++++++++++++++++-------------
gcc/ada/accessibility.ads | 9 +-
gcc/ada/exp_ch4.adb | 14 ++-
3 files changed, 149 insertions(+), 68 deletions(-)
diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index fcd30dde28f..702ab6c5f37 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -990,11 +990,11 @@ package body Accessibility is
end case;
end Accessibility_Level;
- ---------------------------------------------
- -- Apply_Accessibility_Check_For_Allocator --
- ---------------------------------------------
+ --------------------------------------------------------
+ -- Apply_Accessibility_Check_For_Class_Wide_Allocator --
+ --------------------------------------------------------
- procedure Apply_Accessibility_Check_For_Allocator
+ procedure Apply_Accessibility_Check_For_Class_Wide_Allocator
(N : Node_Id;
Exp : Node_Id;
Ref : Node_Id;
@@ -1025,14 +1025,13 @@ package body Accessibility is
-- If the allocator was built in place, Ref is already a reference
-- to the access object initialized to the result of the allocator
-- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
- -- Remove_Side_Effects for cases where the build-in-place call may
+ -- Duplicate_Subexpr for cases where the build-in-place call may
-- still be the prefix of the reference (to avoid generating
-- duplicate calls). Otherwise, it is the entity associated with
-- the object containing the address of the allocated object.
if Built_In_Place then
- Remove_Side_Effects (Ref);
- Obj_Ref := New_Copy_Tree (Ref);
+ Obj_Ref := Duplicate_Subexpr (Ref);
else
Obj_Ref := New_Occurrence_Of (Ref, Loc);
end if;
@@ -1178,7 +1177,7 @@ package body Accessibility is
Then_Statements => Stmts),
Suppress => All_Checks);
end if;
- end Apply_Accessibility_Check_For_Allocator;
+ end Apply_Accessibility_Check_For_Class_Wide_Allocator;
----------------------------------------------------
-- Apply_Accessibility_Check_For_Anonymous_Return --
@@ -1367,6 +1366,102 @@ package body Accessibility is
end if;
end Apply_Accessibility_Check_For_Class_Wide_Return;
+ -----------------------------------------------------------
+ -- Apply_Accessibility_Check_For_Discriminated_Allocator --
+ -----------------------------------------------------------
+
+ procedure Apply_Accessibility_Check_For_Discriminated_Allocator
+ (N : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (Expression (N));
+ Exp : constant Node_Id := Unqualify (Expression (N));
+ Exp_Typ : constant Entity_Id := Etype (Exp);
+
+ Discr : Entity_Id;
+ Discr_Elmt : Elmt_Id;
+ Discr_Exp : Node_Id;
+
+ -- Start of Apply_Accessibility_Check_For_Discriminated_Allocator
+
+ begin
+ -- Return immediately if accessibility checks are suppressed for N
+
+ if Scope_Suppress.Suppress (Accessibility_Check)
+ or else No_Dynamic_Accessibility_Checks_Enabled (N)
+ then
+ return;
+
+ -- Check that the allocator's access discriminants do not designate
+ -- entities that the allocator could outlive (RM 4.8(10.1)).
+
+ elsif not Has_Anonymous_Access_Discriminant (Typ) then
+ return;
+
+ -- We ignore coextensions as they cannot be implemented under the
+ -- "small integer" model.
+
+ elsif Is_Static_Coextension (N) or else Is_Dynamic_Coextension (N) then
+ return;
+
+ -- If we are allocating a function result, then that function will
+ -- perform the check.
+
+ elsif Nkind (Exp) = N_Function_Call then
+ return;
+
+ -- When the value of the access discriminant is determined by
+ -- an object with an unconstrained nominal subtype, its level
+ -- is the accessibility level of the object (RM 3.10.2(12.4)).
+
+ elsif not Is_Constrained (Exp_Typ) then
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Accessibility_Level (Exp, Dynamic_Level),
+ Right_Opnd => Accessibility_Level (N, Dynamic_Level)),
+ Reason => PE_Accessibility_Check_Failed),
+ Suppress => Access_Check);
+
+ return;
+ end if;
+
+ Discr := First_Discriminant (Typ);
+ Discr_Elmt := First_Elmt (Discriminant_Constraint (Exp_Typ));
+
+ while Present (Discr) loop
+ if Is_Anonymous_Access_Type (Etype (Discr)) then
+ Discr_Exp := Node (Discr_Elmt);
+
+ -- The accessibility level of a function call whose result type is
+ -- an anonymous access type used to define the discriminant of an
+ -- object is the level of the object (RM 3.10.2(10.3, 14.1)).
+
+ if Nkind (Original_Node (Discr_Exp)) = N_Function_Call
+ and then
+ Is_Anonymous_Access_Type (Etype (Original_Node (Discr_Exp)))
+ then
+ null;
+
+ else
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Accessibility_Level (Discr_Exp, Dynamic_Level),
+ Right_Opnd => Accessibility_Level (N, Dynamic_Level)),
+ Reason => PE_Accessibility_Check_Failed),
+ Suppress => Access_Check);
+ end if;
+ end if;
+
+ Next_Discriminant (Discr);
+ Next_Elmt (Discr_Elmt);
+ end loop;
+ end Apply_Accessibility_Check_For_Discriminated_Allocator;
+
--------------------------------------------------------
-- Apply_Accessibility_Check_For_Discriminated_Return --
--------------------------------------------------------
@@ -1389,18 +1484,11 @@ package body Accessibility is
procedure Apply_Accessibility_Check_For_Discriminated_Return
(Exp : Node_Id; Func : Entity_Id)
is
- Loc : constant Source_Ptr := Sloc (Exp);
-
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.
-
---------------------------------------
-- Constraint_Bearing_Subtype_If_Any --
---------------------------------------
@@ -1448,31 +1536,11 @@ package body Accessibility is
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;
-
-- Local variables
- Constrained_Subtype : constant Entity_Id :=
- Constraint_Bearing_Subtype_If_Any (Exp);
-
- Discr : Entity_Id := First_Discriminant (Etype (Func));
- Discr_Index : Positive := 1;
- Discr_Exp : Node_Id;
+ Discr : Entity_Id;
+ Discr_Elmt : Elmt_Id;
+ Exp_Typ : Entity_Id;
-- Start of Apply_Accessibility_Check_For_Discriminated_Return
@@ -1486,14 +1554,12 @@ package body Accessibility is
if Ada_Version <= Ada_95 then
return;
- end if;
- -- If we are returning a function call then that function will
- -- perform the needed check.
+ -- If we are returning a function result, then that function will
+ -- perform the check.
- if Nkind (Unqualify (Exp)) = N_Function_Call then
+ elsif Nkind (Unqualify (Exp)) = N_Function_Call then
return;
- end if;
-- ??? Cope with the consequences of the Disable_Tagged_Cases flag
-- in accessibility.adb (which can cause the extra formal parameter
@@ -1502,33 +1568,33 @@ package body Accessibility is
-- prevent generation of a required check (or even a required
-- legality check - see "statically too deep" check below).
- if No (Extra_Accessibility_Of_Result (Func)) then
+ elsif No (Extra_Accessibility_Of_Result (Func)) then
return;
end if;
- Remove_Side_Effects (Exp);
+ Exp_Typ := Constraint_Bearing_Subtype_If_Any (Exp);
+
+ -- When the value of the access discriminant is determined by
+ -- an object with an unconstrained nominal subtype, its level
+ -- is the accessibility level of the object (RM 3.10.2(12.4)).
+
+ if not Is_Constrained (Exp_Typ) then
+ Apply_Accessibility_Check_For_Anonymous_Return (Exp, Func, Exp);
+
+ return;
+ end if;
+
+ Discr := First_Discriminant (Etype (Func));
+ Discr_Elmt := First_Elmt (Discriminant_Constraint (Exp_Typ));
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;
-
- Analyze (Discr_Exp);
-
Apply_Accessibility_Check_For_Anonymous_Return
- (Discr_Exp, Func, Exp);
+ (Node (Discr_Elmt), Func, Exp);
end if;
Next_Discriminant (Discr);
- Discr_Index := Discr_Index + 1;
+ Next_Elmt (Discr_Elmt);
end loop;
end Apply_Accessibility_Check_For_Discriminated_Return;
@@ -1654,7 +1720,7 @@ package body Accessibility is
Typ : constant Entity_Id := Etype (Func);
begin
- -- Return immediately if accessiblity checks are suppressed for Func
+ -- Return immediately if accessibility checks are suppressed for Func
if Accessibility_Checks_Suppressed (Func) then
return;
@@ -1675,13 +1741,13 @@ package body Accessibility is
Apply_Accessibility_Check_For_Class_Wide_Return (Exp, Func);
-- Check that the access result does not designate an entity that
- -- the function result could outlive.
+ -- the result could outlive.
elsif Ekind (Typ) = E_Anonymous_Access_Type then
Apply_Accessibility_Check_For_Anonymous_Return (Exp, Func, Exp);
- -- Check that result's access discriminants (if any) do not designate
- -- entities that the function result could outlive.
+ -- Check that the result's access discriminants do not designate
+ -- entities that the result could outlive (RM 6.5(21)).
elsif Has_Anonymous_Access_Discriminant (Typ) then
Apply_Accessibility_Check_For_Discriminated_Return (Exp, Func);
diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads
index 958d5f6375b..6790864d7d7 100644
--- a/gcc/ada/accessibility.ads
+++ b/gcc/ada/accessibility.ads
@@ -71,7 +71,7 @@ package Accessibility is
-- The Allow_Alt_Model parameter allows the alternative level calculation
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
- procedure Apply_Accessibility_Check_For_Allocator
+ procedure Apply_Accessibility_Check_For_Class_Wide_Allocator
(N : Node_Id;
Exp : Node_Id;
Ref : Node_Id;
@@ -111,6 +111,13 @@ package Accessibility is
-- type of the object is not deeper than the level of Typ. Insert_Node
-- indicates the node where the check should be inserted.
+ procedure Apply_Accessibility_Check_For_Discriminated_Allocator
+ (N : Node_Id);
+ -- If the subtype determined by the subtype indication or the qualified
+ -- expression of an allocator N has access discriminants, insert checks
+ -- that the accessibility level of each entity designated by an access
+ -- discriminant is not deeper than the level of the allocator.
+
procedure Apply_Accessibility_Check_For_Return
(Exp : Node_Id;
Func : Entity_Id);
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 52826388282..7279fe3cf76 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -794,6 +794,10 @@ package body Exp_Ch4 is
return;
end if;
+ -- Apply accessibility checks if access discriminants are present
+
+ Apply_Accessibility_Check_For_Discriminated_Allocator (N);
+
-- If we have:
-- type A is access T1;
-- X : A := new T2'(...);
@@ -858,7 +862,7 @@ package body Exp_Ch4 is
if Is_Build_In_Place_Function_Call (Exp) then
Make_Build_In_Place_Call_In_Allocator (N, Exp);
- Apply_Accessibility_Check_For_Allocator
+ Apply_Accessibility_Check_For_Class_Wide_Allocator
(N, Exp, N, Built_In_Place => True);
return;
@@ -871,7 +875,7 @@ package body Exp_Ch4 is
elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then
Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp);
- Apply_Accessibility_Check_For_Allocator
+ Apply_Accessibility_Check_For_Class_Wide_Allocator
(N, Exp, N, Built_In_Place => True);
return;
end if;
@@ -1100,7 +1104,7 @@ package body Exp_Ch4 is
-- Note: the accessibility check must be inserted after the call to
-- [Deep_]Adjust to ensure proper completion of the assignment.
- Apply_Accessibility_Check_For_Allocator (N, Exp, Temp);
+ Apply_Accessibility_Check_For_Class_Wide_Allocator (N, Exp, Temp);
-- Case of aggregate built in place
@@ -4863,6 +4867,10 @@ package body Exp_Ch4 is
-- that tasks get activated (see Build_Task_Allocate_Block for details).
else
+ -- Apply accessibility checks if access discriminants are present
+
+ Apply_Accessibility_Check_For_Discriminated_Allocator (N);
+
-- Apply constraint checks against designated subtype (RM 4.8(10/2)).
-- Discriminant checks will be generated by the expansion below.
--
2.53.0
