public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-2021] [Ada] INOX: prototype alternative accessibility model
@ 2021-07-05 13:14 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-07-05 13:14 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:bcb8c3bba756feb252340757e0944956684b7cfb
commit r12-2021-gbcb8c3bba756feb252340757e0944956684b7cfb
Author: Justin Squirek <squirek@adacore.com>
Date: Mon Mar 29 08:46:02 2021 -0400
[Ada] INOX: prototype alternative accessibility model
gcc/ada/
* checks.adb (Accessibility_Checks_Suppressed): Add check
against restriction No_Dynamic_Accessibility_Checks.
(Apply_Accessibility_Check): Add assertion to check restriction
No_Dynamic_Accessibility_Checks is not active.
* debug.adb: Add documentation for new debugging switch to
control which accessibility model gets employed under
restriction No_Dynamic_Accessibility_Checks.
* exp_attr.adb (Expand_N_Attribute_Reference): Disable dynamic
accessibility check generation when
No_Dynamic_Accessibility_Checks is active.
* exp_ch4.adb (Apply_Accessibility_Check): Skip check generation
when restriction No_Dynamic_Accessibility_Checks is active.
(Expand_N_Allocator): Disable dynamic accessibility checks when
No_Dynamic_Accessibility_Checks is active.
(Expand_N_In): Disable dynamic accessibility checks when
No_Dynamic_Accessibility_Checks is active.
(Expand_N_Type_Conversion): Disable dynamic accessibility checks
when No_Dynamic_Accessibility_Checks is active.
* exp_ch5.adb (Expand_N_Assignment_Statement): Disable
alternative accessibility model calculations when computing a
dynamic level for a SAOAAT.
* exp_ch6.adb (Add_Call_By_Copy_Code): Disable dynamic
accessibility check generation when
No_Dynamic_Accessibility_Checks is active.
(Expand_Branch): Disable alternative accessibility model
calculations.
(Expand_Call_Helper): Disable alternative accessibility model
calculations.
* restrict.adb, restrict.ads: Add new restriction
No_Dynamic_Accessibility_Checks.
(No_Dynamic_Accessibility_Checks_Enabled): Created to test when
experimental features (which are generally incompatible with
standard Ada) can be enabled.
* sem_attr.adb (Safe_Value_Conversions): Add handling of new
accessibility model under the restriction
No_Dynamic_Accessibility_Checks.
* sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
Disallow new restriction No_Dynamic_Accessibility_Checks from
being exclusively specified within a body or subunit without
being present in a specification.
* sem_res.adb (Check_Fully_Declared_Prefix): Minor comment
fixup.
(Valid_Conversion): Omit implicit conversion checks on anonymous
access types and perform static checking instead when
No_Dynamic_Accessibility_Checks is active.
* sem_util.adb, sem_util.ads (Accessibility_Level): Add special
handling of anonymous access objects, formal parameters,
anonymous access components, and function return objects.
(Deepest_Type_Access_Level): When
No_Dynamic_Accessibility_Checks is active employ an alternative
model. Add paramter Allow_Alt_Model to override the new behavior
in certain cases.
(Type_Access_Level): When No_Dynamic_Accessibility_Checks is
active employ an alternative model. Add parameter
Allow_Alt_Model to override the new behavior in certain cases.
(Typ_Access_Level): Created within Accessibility_Level for
convenience.
* libgnat/s-rident.ads, snames.ads-tmpl: Add handing for
No_Dynamic_Accessibility_Checks.
Diff:
---
gcc/ada/checks.adb | 11 ++-
gcc/ada/debug.adb | 2 +-
gcc/ada/exp_attr.adb | 1 +
gcc/ada/exp_ch4.adb | 5 +
gcc/ada/exp_ch5.adb | 4 +-
gcc/ada/exp_ch6.adb | 29 ++++--
gcc/ada/libgnat/s-rident.ads | 1 +
gcc/ada/restrict.adb | 15 +++
gcc/ada/restrict.ads | 10 ++
gcc/ada/sem_attr.adb | 13 ++-
gcc/ada/sem_prag.adb | 35 +++++++
gcc/ada/sem_res.adb | 22 ++++-
gcc/ada/sem_util.adb | 215 ++++++++++++++++++++++++++++++++++++-------
gcc/ada/sem_util.ads | 23 ++++-
gcc/ada/snames.ads-tmpl | 1 +
15 files changed, 332 insertions(+), 55 deletions(-)
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 6c49e671e91..96a2a3f3df1 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -379,8 +379,12 @@ package body Checks is
function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- if Present (E) and then Checks_May_Be_Suppressed (E) then
+ if No_Dynamic_Accessibility_Checks_Enabled (E) then
+ return True;
+
+ elsif Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Accessibility_Check);
+
else
return Scope_Suppress.Suppress (Accessibility_Check);
end if;
@@ -582,6 +586,11 @@ package body Checks is
Type_Level : Node_Id;
begin
+ -- Verify we haven't tried to add a dynamic accessibility check when we
+ -- shouldn't.
+
+ pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N));
+
if Ada_Version >= Ada_2012
and then not Present (Param_Ent)
and then Is_Entity_Name (N)
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 978f333e9cc..5a4d1d3cdaa 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -140,7 +140,7 @@ package body Debug is
-- d.Z Do not enable expansion in configurable run-time mode
-- d_a Stop elaboration checks on accept or select statement
- -- d_b
+ -- d_b Use compatibility model under No_Dynamic_Accessibility_Checks
-- d_c CUDA compilation : compile for the host
-- d_d
-- d_e Ignore entry calls and requeue statements for elaboration
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index af7f205d50c..067e7ede704 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -2366,6 +2366,7 @@ package body Exp_Attr is
= E_Anonymous_Access_Type
and then Present (Extra_Accessibility
(Entity (Prefix (Enc_Object))))
+ and then not No_Dynamic_Accessibility_Checks_Enabled (Enc_Object)
then
Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 54e91b2f2e3..d608a30a691 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -615,6 +615,7 @@ package body Exp_Ch4 is
and then Is_Class_Wide_Type (DesigT)
and then Tagged_Type_Expansion
and then not Scope_Suppress.Suppress (Accessibility_Check)
+ and then not No_Dynamic_Accessibility_Checks_Enabled (Ref)
and then
(Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
or else
@@ -5277,6 +5278,8 @@ package body Exp_Ch4 is
if Ada_Version >= Ada_2005
and then
Ekind (Etype (Nod)) = E_Anonymous_Access_Type
+ and then not
+ No_Dynamic_Accessibility_Checks_Enabled (Nod)
then
Apply_Accessibility_Check
(Nod, Typ, Insert_Node => Nod);
@@ -6865,6 +6868,7 @@ package body Exp_Ch4 is
if Ada_Version >= Ada_2012
and then Is_Acc
and then Ekind (Ltyp) = E_Anonymous_Access_Type
+ and then not No_Dynamic_Accessibility_Checks_Enabled (Lop)
then
declare
Expr_Entity : Entity_Id := Empty;
@@ -12333,6 +12337,7 @@ package body Exp_Ch4 is
and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type
and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
or else Attribute_Name (Original_Node (N)) = Name_Access)
+ and then not No_Dynamic_Accessibility_Checks_Enabled (N)
then
if not Comes_From_Source (N)
and then Nkind (Parent (N)) in N_Function_Call
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 4eba6fb4208..2cc8b64f083 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -2771,7 +2771,9 @@ package body Exp_Ch5 is
(Entity (Lhs)), Loc),
Expression =>
Accessibility_Level
- (Rhs, Dynamic_Level));
+ (Expr => Rhs,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False));
begin
if not Accessibility_Checks_Suppressed (Entity (Lhs)) then
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 3542411f400..80ed21b5972 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -1803,6 +1803,7 @@ package body Exp_Ch6 is
and then Is_Entity_Name (Lhs)
and then
Present (Effective_Extra_Accessibility (Entity (Lhs)))
+ and then not No_Dynamic_Accessibility_Checks_Enabled (Lhs)
then
-- Copyback target is an Ada 2012 stand-alone object of an
-- anonymous access type.
@@ -2929,7 +2930,9 @@ package body Exp_Ch6 is
Name => New_Occurrence_Of (Lvl, Loc),
Expression =>
Accessibility_Level
- (Expression (Res_Assn), Dynamic_Level)));
+ (Expr => Expression (Res_Assn),
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False)));
end if;
end Expand_Branch;
@@ -3857,9 +3860,10 @@ package body Exp_Ch6 is
end if;
Add_Extra_Actual
- (Expr =>
- New_Occurrence_Of
- (Get_Dynamic_Accessibility (Parm_Ent), Loc),
+ (Expr => Accessibility_Level
+ (Expr => Parm_Ent,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False),
EF => Extra_Accessibility (Formal));
end;
@@ -3890,15 +3894,20 @@ package body Exp_Ch6 is
Add_Extra_Actual
(Expr => Accessibility_Level
- (Expr => Expression (Parent (Entity (Prev))),
- Level => Dynamic_Level),
+ (Expr => Expression
+ (Parent (Entity (Prev))),
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False),
EF => Extra_Accessibility (Formal));
-- Normal case
else
Add_Extra_Actual
- (Expr => Accessibility_Level (Prev, Dynamic_Level),
+ (Expr => Accessibility_Level
+ (Expr => Prev,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False),
EF => Extra_Accessibility (Formal));
end if;
end if;
@@ -4142,8 +4151,10 @@ package body Exp_Ch6 is
-- Otherwise get the level normally based on the call node
else
- Level := Accessibility_Level (Call_Node, Dynamic_Level);
-
+ Level := Accessibility_Level
+ (Expr => Call_Node,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False);
end if;
-- It may be possible that we are re-expanding an already
diff --git a/gcc/ada/libgnat/s-rident.ads b/gcc/ada/libgnat/s-rident.ads
index 7d0a384b20e..10d374ee539 100644
--- a/gcc/ada/libgnat/s-rident.ads
+++ b/gcc/ada/libgnat/s-rident.ads
@@ -103,6 +103,7 @@ package System.Rident is
No_Direct_Boolean_Operators, -- GNAT
No_Dispatch, -- (RM H.4(19))
No_Dispatching_Calls, -- GNAT
+ No_Dynamic_Accessibility_Checks, -- GNAT
No_Dynamic_Attachment, -- Ada 2012 (RM E.7(10/3))
No_Dynamic_CPU_Assignment, -- Ada 202x (RM D.7(10/3))
No_Dynamic_Priorities, -- (RM D.9(9))
diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb
index 35922307460..4f1dea4adef 100644
--- a/gcc/ada/restrict.adb
+++ b/gcc/ada/restrict.adb
@@ -924,6 +924,21 @@ package body Restrict is
or else Targparm.Restrictions_On_Target.Set (No_Tasking);
end Global_No_Tasking;
+ ---------------------------------------------
+ -- No_Dynamic_Accessibility_Checks_Enabled --
+ ---------------------------------------------
+
+ function No_Dynamic_Accessibility_Checks_Enabled
+ (N : Node_Id) return Boolean
+ is
+ pragma Unreferenced (N);
+ -- N is currently unreferenced but present for debugging purposes and
+ -- potential future use.
+
+ begin
+ return Restrictions.Set (No_Dynamic_Accessibility_Checks);
+ end No_Dynamic_Accessibility_Checks_Enabled;
+
-------------------------------
-- No_Exception_Handlers_Set --
-------------------------------
diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads
index 806195e3d0f..eec85c21283 100644
--- a/gcc/ada/restrict.ads
+++ b/gcc/ada/restrict.ads
@@ -114,6 +114,7 @@ package Restrict is
No_Default_Initialization => True,
No_Direct_Boolean_Operators => True,
No_Dispatching_Calls => True,
+ No_Dynamic_Accessibility_Checks => True,
No_Dynamic_Attachment => True,
No_Elaboration_Code => True,
No_Enumeration_Maps => True,
@@ -377,6 +378,15 @@ package Restrict is
-- pragma Restrictions_Warning, or attribute Restriction_Set. Returns
-- True if N has the proper form for an entity name, False otherwise.
+ function No_Dynamic_Accessibility_Checks_Enabled
+ (N : Node_Id) return Boolean;
+ -- Test to see if the current restrictions settings specify that
+ -- No_Dynamic_Accessibility_Checks is activated.
+
+ -- N is currently unused, but is reserved for future use and debugging
+ -- purposes to provide more context on a node for which an accessibility
+ -- check is being performed or generated (e.g. is N in a predefined unit).
+
function No_Exception_Handlers_Set return Boolean;
-- Test to see if current restrictions settings specify that no exception
-- handlers are present. This function is called by Gigi when it needs to
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index b7297e5edfd..e0b2072307f 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -11290,7 +11290,11 @@ package body Sem_Attr is
-- this kind of warning is an error in SPARK mode.
if In_Instance_Body then
- Error_Msg_Warn := SPARK_Mode /= On;
+ Error_Msg_Warn :=
+ SPARK_Mode /= On
+ and then
+ not No_Dynamic_Accessibility_Checks_Enabled (P);
+
Error_Msg_F
("non-local pointer cannot point to local object<<", P);
Error_Msg_F ("\Program_Error [<<", P);
@@ -11422,10 +11426,13 @@ package body Sem_Attr is
-- Check the static accessibility rule of 3.10.2(28). Note that
-- this check is not performed for the case of an anonymous
-- access type, since the access attribute is always legal
- -- in such a context.
+ -- in such a context - unless the restriction
+ -- No_Dynamic_Accessibility_Checks is active.
if Attr_Id /= Attribute_Unchecked_Access
- and then Ekind (Btyp) = E_General_Access_Type
+ and then
+ (Ekind (Btyp) = E_General_Access_Type
+ or else No_Dynamic_Accessibility_Checks_Enabled (Btyp))
-- Call Accessibility_Level directly to avoid returning zero
-- on cases where the prefix is an explicitly aliased
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 36b305eec31..fa63fdae730 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -10483,6 +10483,41 @@ package body Sem_Prag is
Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
end if;
+ -- Special processing for No_Dynamic_Accessibility_Checks to
+ -- disallow exclusive specification in a body or subunit.
+
+ elsif R_Id = No_Dynamic_Accessibility_Checks
+ -- Check if the restriction is within configuration pragma
+ -- in a similar way to No_Elaboration_Code.
+
+ and then not (Current_Sem_Unit = Main_Unit
+ or else In_Extended_Main_Source_Unit (N))
+
+ and then Nkind (Unit (Parent (N))) = N_Compilation_Unit
+
+ and then (Nkind (Unit (Parent (N))) = N_Package_Body
+ or else Nkind (Unit (Parent (N))) = N_Subunit)
+
+ and then not Restriction_Active
+ (No_Dynamic_Accessibility_Checks)
+ then
+ Error_Msg_N
+ ("invalid specification of " &
+ """No_Dynamic_Accessibility_Checks""", N);
+
+ if Nkind (Unit (Parent (N))) = N_Package_Body then
+ Error_Msg_N
+ ("\restriction cannot be specified in a package " &
+ "body", N);
+
+ elsif Nkind (Unit (Parent (N))) = N_Subunit then
+ Error_Msg_N
+ ("\restriction cannot be specified in a subunit", N);
+ end if;
+
+ Error_Msg_N
+ ("\unless also specified in spec", N);
+
-- Special processing for No_Tasking restriction (not just a
-- warning) when it appears as a configuration pragma.
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index b6a9b1d653c..fb40484f2a6 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -654,9 +654,9 @@ package body Sem_Res is
end if;
end Check_For_Visible_Operator;
- ----------------------------------
- -- Check_Fully_Declared_Prefix --
- ----------------------------------
+ ---------------------------------
+ -- Check_Fully_Declared_Prefix --
+ ---------------------------------
procedure Check_Fully_Declared_Prefix
(Typ : Entity_Id;
@@ -13676,12 +13676,24 @@ package body Sem_Res is
then
if Is_Itype (Opnd_Type) then
+ -- When applying restriction No_Dynamic_Accessibility_Check,
+ -- implicit conversions are allowed when the operand type is
+ -- not deeper than the target type.
+
+ if No_Dynamic_Accessibility_Checks_Enabled (N) then
+ if Type_Access_Level (Opnd_Type)
+ > Deepest_Type_Access_Level (Target_Type)
+ then
+ Conversion_Error_N
+ ("operand has deeper level than target", Operand);
+ end if;
+
-- Implicit conversions aren't allowed for objects of an
-- anonymous access type, since such objects have nonstatic
-- levels in Ada 2012.
- if Nkind (Associated_Node_For_Itype (Opnd_Type)) =
- N_Object_Declaration
+ elsif Nkind (Associated_Node_For_Itype (Opnd_Type))
+ = N_Object_Declaration
then
Conversion_Error_N
("implicit conversion of stand-alone anonymous "
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index b7d84afd69d..e0a12bddca1 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -177,9 +177,9 @@ package body Sem_Util is
-- "subp:file:line:col", corresponding to the source location of the
-- body of the subprogram.
- ------------------------------
- -- Abstract_Interface_List --
- ------------------------------
+ -----------------------------
+ -- Abstract_Interface_List --
+ -----------------------------
function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
Nod : Node_Id;
@@ -260,7 +260,8 @@ package body Sem_Util is
function Accessibility_Level
(Expr : Node_Id;
Level : Accessibility_Level_Kind;
- In_Return_Context : Boolean := False) return Node_Id
+ In_Return_Context : Boolean := False;
+ Allow_Alt_Model : Boolean := True) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Expr);
@@ -281,6 +282,11 @@ package body Sem_Util is
-- Centralized processing of subprogram calls which may appear in
-- prefix notation.
+ function Typ_Access_Level (Typ : Entity_Id) return Uint
+ is (Type_Access_Level (Typ, Allow_Alt_Model));
+ -- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid
+ -- passing the parameter specifically in every call.
+
----------------------------------
-- Innermost_Master_Scope_Depth --
----------------------------------
@@ -375,7 +381,7 @@ package body Sem_Util is
(Subprogram_Access_Level (Entity (Name (N))));
else
return Make_Level_Literal
- (Type_Access_Level (Etype (Prefix (Name (N)))));
+ (Typ_Access_Level (Etype (Prefix (Name (N)))));
end if;
-- We ignore coextensions as they cannot be implemented under the
@@ -392,19 +398,39 @@ package body Sem_Util is
-- Named access types have a designated level
if Is_Named_Access_Type (Etype (N)) then
- return Make_Level_Literal (Type_Access_Level (Etype (N)));
+ return Make_Level_Literal (Typ_Access_Level (Etype (N)));
-- Otherwise, the level is dictated by RM 3.10.2 (10.7/3)
else
+ -- Check No_Dynamic_Accessibility_Checks restriction override for
+ -- alternative accessibility model.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (N)
+ and then Is_Anonymous_Access_Type (Etype (N))
+ then
+ -- In the alternative model the level is that of the subprogram
+
+ if Debug_Flag_Underscore_B then
+ return Make_Level_Literal
+ (Subprogram_Access_Level (Current_Subprogram));
+ end if;
+
+ -- Otherwise the level is that of the designated type
+
+ return Make_Level_Literal
+ (Typ_Access_Level (Etype (N)));
+ end if;
+
if Nkind (N) = N_Function_Call then
-- Dynamic checks are generated when we are within a return
-- value or we are in a function call within an anonymous
-- access discriminant constraint of a return object (signified
-- by In_Return_Context) on the side of the callee.
- -- So, in this case, return library accessibility level to null
- -- out the check on the side of the caller.
+ -- So, in this case, return accessibility level of the
+ -- enclosing subprogram.
if In_Return_Value (N)
or else In_Return_Context
@@ -414,6 +440,17 @@ package body Sem_Util is
end if;
end if;
+ -- When the call is being dereferenced the level is that of the
+ -- enclosing master of the dereferenced call.
+
+ if Nkind (Parent (N)) in N_Explicit_Dereference
+ | N_Indexed_Component
+ | N_Selected_Component
+ then
+ return Make_Level_Literal
+ (Innermost_Master_Scope_Depth (Expr));
+ end if;
+
-- Find any relevant enclosing parent nodes that designate an
-- object being initialized.
@@ -434,7 +471,7 @@ package body Sem_Util is
and then Is_Named_Access_Type (Etype (Par))
then
return Make_Level_Literal
- (Type_Access_Level (Etype (Par)));
+ (Typ_Access_Level (Etype (Par)));
end if;
-- Jump out when we hit an object declaration or the right-hand
@@ -551,7 +588,7 @@ package body Sem_Util is
if Is_Named_Access_Type (Etype (Pre)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (Pre)));
+ (Typ_Access_Level (Etype (Pre)));
-- Anonymous access types
@@ -616,8 +653,36 @@ package body Sem_Util is
(Scope_Depth (Standard_Standard));
end if;
- return
- New_Occurrence_Of (Get_Dynamic_Accessibility (E), Loc);
+ -- No_Dynamic_Accessibility_Checks restriction override for
+ -- alternative accessibility model.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (E)
+ then
+ -- In the alternative model the level depends on the
+ -- entity's context.
+
+ if Debug_Flag_Underscore_B then
+ if Is_Formal (E) then
+ return Make_Level_Literal
+ (Subprogram_Access_Level
+ (Enclosing_Subprogram (E)));
+ end if;
+
+ return Make_Level_Literal
+ (Scope_Depth (Enclosing_Dynamic_Scope (E)));
+ end if;
+
+ -- Otherwise the level is that of the designated type
+
+ return Make_Level_Literal
+ (Typ_Access_Level (Etype (E)));
+ end if;
+
+ -- Return the dynamic level in the normal case
+
+ return New_Occurrence_Of
+ (Get_Dynamic_Accessibility (E), Loc);
-- Initialization procedures have a special extra accessitility
-- parameter associated with the level at which the object
@@ -635,8 +700,18 @@ package body Sem_Util is
-- according to RM 3.10.2 (21).
elsif Is_Type (E) then
- return Make_Level_Literal
- (Type_Access_Level (E) + 1);
+ -- When restriction No_Dynamic_Accessibility_Checks is active
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (E)
+ and then not Debug_Flag_Underscore_B
+ then
+ return Make_Level_Literal (Typ_Access_Level (E));
+ end if;
+
+ -- Normal path
+
+ return Make_Level_Literal (Typ_Access_Level (E) + 1);
-- Move up the renamed entity if it came from source since
-- expansion may have created a dummy renaming under certain
@@ -651,7 +726,7 @@ package body Sem_Util is
elsif Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (E)));
+ (Typ_Access_Level (Etype (E)));
-- When E is a component of the current instance of a
-- protected type, we assume the level to be deeper than that of
@@ -702,7 +777,7 @@ package body Sem_Util is
elsif Is_Named_Access_Type (Etype (Pre)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (Pre)));
+ (Typ_Access_Level (Etype (Pre)));
-- The current expression is a named access type, so there is no
-- reason to look at the prefix. Instead obtain the level of E's
@@ -710,7 +785,7 @@ package body Sem_Util is
elsif Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (E)));
+ (Typ_Access_Level (Etype (E)));
-- A nondiscriminant selected component where the component
-- is an anonymous access type means that its associated
@@ -723,8 +798,21 @@ package body Sem_Util is
and then Ekind (Entity (Selector_Name (E)))
= E_Discriminant)
then
+ -- When restriction No_Dynamic_Accessibility_Checks is active
+ -- the level is that of the designated type.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (E)
+ and then not Debug_Flag_Underscore_B
+ then
+ return Make_Level_Literal
+ (Typ_Access_Level (Etype (E)));
+ end if;
+
+ -- Otherwise proceed normally
+
return Make_Level_Literal
- (Type_Access_Level (Etype (Prefix (E))));
+ (Typ_Access_Level (Etype (Prefix (E))));
-- Similar to the previous case - arrays featuring components of
-- anonymous access components get their corresponding level from
@@ -736,8 +824,21 @@ package body Sem_Util is
and then Ekind (Component_Type (Base_Type (Etype (Pre))))
= E_Anonymous_Access_Type
then
+ -- When restriction No_Dynamic_Accessibility_Checks is active
+ -- the level is that of the designated type.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (E)
+ and then not Debug_Flag_Underscore_B
+ then
+ return Make_Level_Literal
+ (Typ_Access_Level (Etype (E)));
+ end if;
+
+ -- Otherwise proceed normally
+
return Make_Level_Literal
- (Type_Access_Level (Etype (Prefix (E))));
+ (Typ_Access_Level (Etype (Prefix (E))));
-- The accessibility calculation routine that handles function
-- calls (Function_Call_Level) assumes, in the case the
@@ -785,7 +886,7 @@ package body Sem_Util is
when N_Qualified_Expression =>
if Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (E)));
+ (Typ_Access_Level (Etype (E)));
else
return Accessibility_Level (Expression (E));
end if;
@@ -804,7 +905,7 @@ package body Sem_Util is
-- its type.
if Is_Named_Access_Type (Etype (Pre)) then
- return Make_Level_Literal (Type_Access_Level (Etype (Pre)));
+ return Make_Level_Literal (Typ_Access_Level (Etype (Pre)));
-- Otherwise, recurse deeper
@@ -831,7 +932,7 @@ package body Sem_Util is
elsif Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (E)));
+ (Typ_Access_Level (Etype (E)));
-- In section RM 3.10.2 (10/4) the accessibility rules for
-- aggregates and value conversions are outlined. Are these
@@ -847,7 +948,7 @@ package body Sem_Util is
-- expression's entity.
when others =>
- return Make_Level_Literal (Type_Access_Level (Etype (E)));
+ return Make_Level_Literal (Typ_Access_Level (Etype (E)));
end case;
end Accessibility_Level;
@@ -7102,12 +7203,25 @@ package body Sem_Util is
-- Deepest_Type_Access_Level --
-------------------------------
- function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
+ function Deepest_Type_Access_Level
+ (Typ : Entity_Id;
+ Allow_Alt_Model : Boolean := True) return Uint
+ is
begin
if Ekind (Typ) = E_Anonymous_Access_Type
and then not Is_Local_Anonymous_Access (Typ)
and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
then
+ -- No_Dynamic_Accessibility_Checks override for alternative
+ -- accessibility model.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (Typ)
+ and then Debug_Flag_Underscore_B
+ then
+ return Type_Access_Level (Typ, Allow_Alt_Model);
+ end if;
+
-- Typ is the type of an Ada 2012 stand-alone object of an anonymous
-- access type.
@@ -7123,7 +7237,7 @@ package body Sem_Util is
return UI_From_Int (Int'Last);
else
- return Type_Access_Level (Typ);
+ return Type_Access_Level (Typ, Allow_Alt_Model);
end if;
end Deepest_Type_Access_Level;
@@ -28982,12 +29096,14 @@ package body Sem_Util is
-- Type_Access_Level --
-----------------------
- function Type_Access_Level (Typ : Entity_Id) return Uint is
- Btyp : Entity_Id;
+ function Type_Access_Level
+ (Typ : Entity_Id;
+ Allow_Alt_Model : Boolean := True) return Uint
+ is
+ Btyp : Entity_Id := Base_Type (Typ);
+ Def_Ent : Entity_Id;
begin
- Btyp := Base_Type (Typ);
-
-- Ada 2005 (AI-230): For most cases of anonymous access types, we
-- simply use the level where the type is declared. This is true for
-- stand-alone object declarations, and for anonymous access types
@@ -28998,13 +29114,50 @@ package body Sem_Util is
if Is_Access_Type (Btyp) then
if Ekind (Btyp) = E_Anonymous_Access_Type then
+ -- No_Dynamic_Accessibility_Checks restriction override for
+ -- alternative accessibility model.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (Btyp)
+ then
+ -- In the normal model, the level of an anonymous access
+ -- type is always that of the designated type.
+
+ if not Debug_Flag_Underscore_B then
+ return Type_Access_Level
+ (Designated_Type (Btyp), Allow_Alt_Model);
+ end if;
+
+ -- Otherwise the secondary model dictates special handling
+ -- depending on the context of the anonymous access type.
+
+ -- Obtain the defining entity for the internally generated
+ -- anonymous access type.
+
+ Def_Ent := Defining_Entity_Or_Empty
+ (Associated_Node_For_Itype (Typ));
+
+ if Present (Def_Ent) then
+ -- When the type comes from an anonymous access parameter,
+ -- the level is that of the subprogram declaration.
+
+ if Ekind (Def_Ent) in Subprogram_Kind then
+ return Scope_Depth (Def_Ent);
+
+ -- When the type is an access discriminant, the level is
+ -- that of the type.
+
+ elsif Ekind (Def_Ent) = E_Discriminant then
+ return Scope_Depth (Scope (Def_Ent));
+ end if;
+ end if;
-- If the type is a nonlocal anonymous access type (such as for
-- an access parameter) we treat it as being declared at the
-- library level to ensure that names such as X.all'access don't
-- fail static accessibility checks.
- if not Is_Local_Anonymous_Access (Typ) then
+ elsif not Is_Local_Anonymous_Access (Typ) then
return Scope_Depth (Standard_Standard);
-- If this is a return object, the accessibility level is that of
@@ -29038,7 +29191,7 @@ package body Sem_Util is
-- Treat the return object's type as having the level of the
-- function's result subtype (as per RM05-6.5(5.3/2)).
- return Type_Access_Level (Etype (Scop));
+ return Type_Access_Level (Etype (Scop), Allow_Alt_Model);
end;
end if;
end if;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 0894d034085..a49272e080f 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -65,15 +65,19 @@ package Sem_Util is
function Accessibility_Level
(Expr : Node_Id;
Level : Accessibility_Level_Kind;
- In_Return_Context : Boolean := False) return Node_Id;
+ In_Return_Context : Boolean := False;
+ Allow_Alt_Model : Boolean := True) return Node_Id;
-- Centralized accessibility level calculation routine for finding the
-- accessibility level of a given expression Expr.
- -- In_Return_Context forcing the Accessibility_Level calculations to be
+ -- In_Return_Context forces the Accessibility_Level calculations to be
-- carried out "as if" Expr existed in a return value. This is useful for
-- calculating the accessibility levels for discriminant associations
-- and return aggregates.
+ -- The Allow_Alt_Model parameter allows the alternative level calculation
+ -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String;
-- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to get
-- the given string argument, adding leading and trailing asterisks if they
@@ -662,7 +666,10 @@ package Sem_Util is
-- when pragma Restrictions (No_Finalization) applies, in which case we
-- know that class-wide objects do not contain controlled parts.
- function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint;
+ function Deepest_Type_Access_Level
+ (Typ : Entity_Id;
+ Allow_Alt_Model : Boolean := True) return Uint;
+
-- Same as Type_Access_Level, except that if the type is the type of an Ada
-- 2012 stand-alone object of an anonymous access type, then return the
-- static accessibility level of the object. In that case, the dynamic
@@ -672,6 +679,9 @@ package Sem_Util is
-- in the case of a descendant of a generic formal type (returns Int'Last
-- instead of 0).
+ -- The Allow_Alt_Model parameter allows the alternative level calculation
+ -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
function Defining_Entity (N : Node_Id) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- declaration has a specification, the entity is obtained from the
@@ -3246,9 +3256,14 @@ package Sem_Util is
-- returned, i.e. Traverse_More_Func is called and the result is simply
-- discarded.
- function Type_Access_Level (Typ : Entity_Id) return Uint;
+ function Type_Access_Level
+ (Typ : Entity_Id;
+ Allow_Alt_Model : Boolean := True) return Uint;
-- Return the accessibility level of Typ
+ -- The Allow_Alt_Model parameter allows the alternative level calculation
+ -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
function Type_Without_Stream_Operation
(T : Entity_Id;
Op : TSS_Name_Type := TSS_Null) return Entity_Id;
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 837a878cfda..a67623b788b 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -827,6 +827,7 @@ package Snames is
Name_No_Access_Parameter_Allocators : constant Name_Id := N + $;
Name_No_Coextensions : constant Name_Id := N + $;
Name_No_Dependence : constant Name_Id := N + $;
+ Name_No_Dynamic_Accessibility_Checks : constant Name_Id := N + $;
Name_No_Dynamic_Attachment : constant Name_Id := N + $;
Name_No_Dynamic_Interrupts : constant Name_Id := N + $;
Name_No_Elaboration_Code : constant Name_Id := N + $;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-07-05 13:14 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-07-05 13:14 [gcc r12-2021] [Ada] INOX: prototype alternative accessibility model 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).