GNAT currently implements a static small-integer model for accessibility
checks (with a "minimum" trick), which means that all the accessibility
levels, including the dynamic ones, are based on the static nesting depth
of master constructs.
Ada 2012 and later versions of the language expose serious shortcomings of
this static model, for example the non-enforcement of the strict ordering
for caller/called levels or the flattening of nested levels, although there
were already problems, albeit less serious, for Ada 2005.
This change implements a partially dynamic small-integer model, where the
static nesting depth of master constructs is augmented by the (de facto
dynamic) levels that are passed in to specific subprograms.
The run-time implementation changes are minimal, in particular the location
and number of extra formal parameters created by the compiler are the same,
and the compile-time implementation changes are entirely localized in the
Accessibility unit, with an interface for the rest of the front-end clearly
separating the dynamic from the static computations.
Tested on x86-64/Linux, applied on the mainline.
2026-09-22 Eric Botcazou <[email protected]>
* gen_il-fields.ads (Opt_Field_Enum): Remove Minimum_Accessibility
and add Extra_Accessibility_Of_Subprogram.
* gen_il-gen-gen_entities.adb (Formal_Kind): Likewise.
(Subprogram_Kind): Likewise.
* einfo.ads (Extra_Accessibility_Of_Subprogram): Add description.
(Minimum_Accessibility): Remove description.
* accessibility.ads (Accessibility_Level_Kind): Move to...
(Accessibility_Level): Move to...
(Dynamic_Accessibility_Level): New function declaration.
(Dynamic_Local_Access_Level): Likewise.
(Dynamic_Subprogram_Access_Level): Likewise.
(Get_Dynamic_Accessibility): Delete.
(Static_Accessibility_Level_Kind): Likewise.
(Deepest_Type_Access_Level): Likewise.
(Static_Accessibility_Level): Replace second formal parameter.
(Static_Local_Access_Level): New function declaration.
(Static_Type_Access_Level): Likewise.
(Subprogram_Access_Level): Delete.
(Type_Access_Level): Move to...
* accessibility.adb (Accessibility_Level_Kind): ...here.
(Accessibility_Level): ...here.
(Type_Access_Level): ...here.
(Offset_Static_Level): New function declaration.
(Accessibility_Level): Add Static formal parameter and change the
result type. Change the result type of most nested functions and
ultimately call Offset_Static_Level if Static is set to False.
(Apply_Accessibility_Check_For_Class_Wide_Allocator): Use explicit
static or dynamic variant of level computation functions.
(Apply_Accessibility_Check_For_Anonymous_Return): Likewise.
(Apply_Accessibility_Check_For_Class_Wide_Return): Likewise.
(Apply_Accessibility_Check_For_Discriminated_Allocator): Likewise.
(Apply_Accessibility_Check_For_Conversion): Likewise.
(Check_Return_Construct_Accessibility): Likewise.
(Apply_Accessibility_Check_For_Return): Fix typo in comment.
(Dynamic_Accessibility_Level): New function body.
(Dynamic_Local_Access_Level): Likewise.
(Dynamic_Subprogram_Access_Level): Likewise.
(Dynamic_Type_Access_Level): Likewise.
(Get_Dynamic_Accessibility): Delete.
(Offset_Static_Level): New function body.
(Static_Accessibility_Level): Adjust.
(Static_Local_Access_Level): New function body.
(Static_Subprogram_Access_Level): Likewise.
(Static_Type_Access_Level): Likewise.
(Deepest_Type_Access_Level): Merge implementation into...
(Type_Access_Level): ...this. Add Deepest formal parameter and
change the result type. Compute a base entity and an offset.
* contracts.adb (Build_Subprogram_Contract_Wrapper): Do not move the
declaration of the Extra_Accessibility_Of_Subprogram constant.
* exp_aggr.adb: Add clauses for Accessibility.
(In_Place_Assign_OK): Call Static_Local_Access_Level instead of
doing the level calculation manually.
* exp_attr.adb (Expand_N_Attribute_Reference.Write_Controlling_Tag):
Call appropriate accessibility level calculation routine.
* exp_ch3.adb (Build_Initialization_Call): Likewise.
(Expand_N_Object_Declaration): Likewise.
(Freeze_Type): Likewise.
(Build_Record_Init_Proc): Do not create an extra accessibility
parameter for Activation_Chain and Finalization_Master.
* exp_ch4.adb (Expand_N_In): Call appropriate acccessibility level
calculation routine.
* exp_ch5.adb (Expand_N_Assignment_Statement): Likewise.
* exp_ch6.adb (Expand_Actuals): Likewise.
(Create_Extra_Actuals): Likewise.
* exp_ch9.adb (Expand_N_Requeue_Statement): Likewise and add missing
exception per RM 9.5.4(7.2).
* exp_disp.adb (Make_DT): Likewise.
* sem_attr.adb (Resolve_Attribute): Likewise.
* sem_ch3.adb (Analyze_Component_Declaration): Likewise.
(Build_Derived_Record_Type): Likewise.
(Derived_Type_Declaration): Likewise.
* sem_ch9.adb (Analyze_Requeue): Likewise and remove duplicate code.
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): Likewise.
* sem_res.ads (Resolve_Entry): Remove obsolete comment.
* sem_res.adb (Resolve_Actuals): Likewise.
(Resolve_Allocator): Likewise.
(Valid_Conversion): Likewise.
(Resolve_Entry): Set Analyzed on the entry name before rewriting it.
* sem_util.adb (Check_Unprotected_Access): Likewise.
* sem_ch6.adb (Analyze_Function_Return): Likewise.
(Analyze_Subprogram_Body_Helper): Compute the extra accessibility
of the subprogram instead of minimum accessibility of parameters.
(Create_Extra_Formals): Create an extra accessibility formal for
an access-to-subprogram parameter if the profile of the designated
type has at least one parameter that needs one.
--
Eric Botcazoudiff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index 34d5e6b085f..cf352d640a8 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -57,6 +57,61 @@ package body Accessibility is
-- Local Subprograms --
-----------------------
+ type Accessibility_Level_Kind is
+ (Dynamic_Level, Object_Decl_Level, Library_On_Dynamic_Level);
+ -- Captures the different modes in which an accessibility level could be
+ -- obtained for a given expression. In the context of Accessibility_Level
+ -- function, Accessibility_Level_Kind signals what type of accessibility
+ -- level to obtain.
+
+ -- When Level is Dynamic_Level, a defining identifier associated with an
+ -- access parameter, an access result, or an SAOOAAAT, may be returned,
+ -- and an N_Integer_Literal node in the other cases.
+
+ -- When Level is Object_Decl_Level, an N_Integer_Literal node whose value
+ -- is the level of the declaration of the object is returned in the cases
+ -- where Dynamic_Level returns a defining identifier; in the other cases,
+ -- an N_Integer_Literal is returned like for Dynamic_Level.
+
+ -- When Level is Library_On_Dynamic_Level, an N_Integer_Literal node whose
+ -- value is the library level is returned in the cases where Dynamic_Level
+ -- returns a defining identifier; in the other cases, an N_Integer_Literal
+ -- is returned like for Dynamic_Level.
+
+ -- Note that this description does not take into account the dynamic offset
+ -- that may be added by Offset_Static_Level to an N_Integer_Literal node.
+
+ type Level_T (S : Boolean := False) is record
+ case S is
+ when False => N : Node_Id;
+ when True => U : Uint;
+ end case;
+ end record;
+ -- Result type of the Accessibility_Level function, containing an integer
+ -- when Static is True or a Node_Id when Static is False, see below.
+
+ function Accessibility_Level
+ (Expr : Node_Id;
+ Level : Accessibility_Level_Kind;
+ Static : Boolean := False;
+ In_Return_Context : Boolean := False;
+ Allow_Alt_Model : Boolean := True) return Level_T;
+ -- Centralized accessibility level calculation routine for finding the
+ -- accessibility level of a given expression Expr. Level is as described
+ -- above. If Static is True, the result is meant for a static context,
+ -- typically a static accessibility check, and is therefore required to
+ -- be a value of Level_T (S => True) subtype (which also means that Level
+ -- cannot be Dynamic_Level in this case); otherwise, the result is meant
+ -- for a dynamic context, typically a dynamic accessibility check, and is
+ -- therefore required to be a value of Level_T (S => False) subtype.
+
+ -- In_Return_Context forces the level calculation to be carried out as if
+ -- Expr was an operative constituent of a return value; when it is False,
+ -- the function computes whether that is the case or not.
+
+ -- 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_Anonymous_Return
(Exp : Node_Id;
Func : Entity_Id;
@@ -86,6 +141,43 @@ package body Accessibility is
-- access discriminant of the result is not deeper than the level of the
-- master of the call. Exp is an expression being returned from Func.
+ function Offset_Static_Level
+ (Level : Uint;
+ Subp : Entity_Id) return Node_Id;
+ -- Apply the offset scheme described for Extra_Accessibility_Of_Subprogram
+ -- in Einfo to Level computed within subprogram Subp and return the result.
+ -- The function must be invoked for every static accessibility level, both
+ -- for entities declared, and master constructs present, within Subp, when
+ -- a dynamic accessibility level is being computed.
+
+ type Type_Level_T is record
+ Base : Entity_Id;
+ Offset : Uint;
+ end record;
+ -- Result type of the Type_Access_Level function, containing a base entity
+ -- and an offset. The static accessibility level of the input type is the
+ -- sum of the local accessibility level of the base entity and the offset.
+
+ function Type_Access_Level
+ (Typ : Entity_Id;
+ Deepest : Boolean := False;
+ Allow_Alt_Model : Boolean := True;
+ Assoc_Node : Node_Id := Empty) return Type_Level_T;
+ -- Return the static accessibility level of Typ
+
+ -- When Deepest is True, and Typ is that of an Ada 2012 stand-alone object
+ -- of an anonymous access type, then return the static accessibility level
+ -- of the declaration of the object instead of the library level; moreover,
+ -- in the case of a descendant of a generic formal type, return Int'Last
+ -- instead of the library level.
+
+ -- The Allow_Alt_Model parameter allows the alternative level calculation
+ -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
+ -- Assoc_Node allows for the optional specification of a node associated
+ -- with Typ. This is used only for anonymous access types where the context
+ -- matters in interpreting Typ's level.
+
---------------------------
-- Accessibility_Message --
---------------------------
@@ -146,53 +238,76 @@ package body Accessibility is
function Accessibility_Level
(Expr : Node_Id;
Level : Accessibility_Level_Kind;
+ Static : Boolean := False;
In_Return_Context : Boolean := False;
- Allow_Alt_Model : Boolean := True) return Node_Id
+ Allow_Alt_Model : Boolean := True) return Level_T
is
Loc : constant Source_Ptr := Sloc (Expr);
- function Accessibility_Level (Expr : Node_Id) return Node_Id is
+ function Accessibility_Level (Expr : Node_Id) return Level_T is
(Accessibility_Level
- (Expr, Level, In_Return_Context, Allow_Alt_Model));
+ (Expr, Level, Static, In_Return_Context, Allow_Alt_Model));
-- Renaming of the enclosing function to facilitate recursive calls
- function Make_Level_Literal (Level : Uint) return Node_Id;
- -- Construct an integer literal representing an accessibility level with
- -- its type set to Natural.
-
- function Innermost_Master_Scope_Depth (N : Node_Id) return Uint;
- -- Returns the scope depth of the given node's innermost enclosing scope
- -- (effectively the accessibility level of the innermost enclosing
- -- master).
+ function Enclosing_Master_Level (N : Node_Id) return Level_T;
+ -- Return the accessibility level of the innermost enclosing master
- function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id;
+ function Function_Call_Or_Allocator_Level (N : Node_Id) return Level_T;
-- 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.
+ function Library_Level return Level_T;
+ -- Return the library level
+
+ function Local_Access_Level (E : Entity_Id) return Level_T is
+ (if Static
+ then (S => True, U => Static_Local_Access_Level (E))
+ else (S => False, N => Dynamic_Local_Access_Level (E)));
+ -- Local renaming to select the appropriate variant for entities
+
+ function Make_Level_Literal (Level : Uint) return Node_Id;
+ -- Construct an integer literal representing an accessibility level with
+ -- its type set to Natural.
+
+ function Make_Level_Value (Level : Uint) return Level_T;
+ -- Construct an accessibility level value with from static Level
+
+ function Subprogram_Access_Level (Subp : Entity_Id) return Level_T is
+ (if Static
+ then (S => True, U => Static_Subprogram_Access_Level (Subp))
+ else (S => False, N => Dynamic_Subprogram_Access_Level (Subp)));
+ -- Local renaming to select the appropriate variant for subprograms
+
+ function Type_Access_Level (Typ : Entity_Id) return Level_T is
+ (if Static
+ then (S => True,
+ U => Static_Type_Access_Level
+ (Typ, Allow_Alt_Model => Allow_Alt_Model))
+ else (S => False,
+ N => Dynamic_Type_Access_Level
+ (Typ, Allow_Alt_Model => Allow_Alt_Model)));
+ -- Local renaming to select the appropriate variant for types
- ----------------------------------
- -- Innermost_Master_Scope_Depth --
- ----------------------------------
+ ----------------------------
+ -- Enclosing_Master_Level --
+ ----------------------------
- function Innermost_Master_Scope_Depth (N : Node_Id) return Uint is
- Encl_Scop : Entity_Id;
- Ent : Entity_Id;
- Node_Par : Node_Id := Parent (N);
- Master_Lvl_Modifier : Int := 0;
+ function Enclosing_Master_Level (N : Node_Id) return Level_T is
+ Encl_Scop : Entity_Id;
+ Ent : Entity_Id;
+ Level_Modifier : Int := 0;
+ Node_Par : Node_Id;
begin
-- Locate the nearest enclosing node (by traversing Parents)
-- that Defining_Entity can be applied to, and return the
- -- depth of that entity's nearest enclosing dynamic scope.
+ -- level of that entity's nearest enclosing dynamic scope.
-- The RM 7.6.1(3) definition of "master" includes statements
-- and conditions for loops among other things. Are these cases
-- detected properly ???
+ Node_Par := Parent (N);
while Present (Node_Par) loop
Ent := Defining_Entity_Or_Empty (Node_Par);
@@ -208,25 +323,43 @@ package body Accessibility is
or else (Nkind (Node_Par) = N_Object_Renaming_Declaration
and then Comes_From_Iterator (Node_Par))
then
+ -- Note that in some rare cases the scope depth may not be
+ -- set, for example, when we are in the middle of analyzing
+ -- a type and the enclosing scope is said type. In that case
+ -- simply return the library level.
+
+ if not Scope_Depth_Set (Encl_Scop) then
+ return Library_Level;
+ end if;
+
-- Handle the case of expressions within library level
-- subprograms here by adding one to the level modifier.
if Encl_Scop = Standard_Standard
and then Nkind (Node_Par) = N_Subprogram_Body
then
- Master_Lvl_Modifier := Master_Lvl_Modifier + 1;
+ Level_Modifier := Level_Modifier + 1;
end if;
- -- Note that in some rare cases the scope depth may not be
- -- set, for example, when we are in the middle of analyzing
- -- a type and the enclosing scope is said type. In that case
- -- simply return zero for the outermost scope.
+ declare
+ Subp : constant Entity_Id :=
+ (if Is_Subprogram (Encl_Scop)
+ then Encl_Scop
+ else Enclosing_Subprogram (Encl_Scop));
+ Static_Level : constant Uint :=
+ Scope_Depth (Encl_Scop) + Level_Modifier;
- if Scope_Depth_Set (Encl_Scop) then
- return Scope_Depth (Encl_Scop) + Master_Lvl_Modifier;
- else
- return Uint_0;
- end if;
+ begin
+ if Static then
+ return (S => True, U => Static_Level);
+ elsif No (Subp) then
+ return (S => False,
+ N => Make_Level_Literal (Static_Level));
+ else
+ return (S => False,
+ N => Offset_Static_Level (Static_Level, Subp));
+ end if;
+ end;
end if;
-- For a return statement within a function, return
@@ -238,7 +371,19 @@ package body Accessibility is
elsif Nkind (Node_Par) in N_Extended_Return_Statement
| N_Simple_Return_Statement
then
- return Scope_Depth (Enclosing_Subprogram (Node_Par));
+ declare
+ Subp : constant Entity_Id :=
+ Enclosing_Subprogram (Node_Par);
+ Static_Level : constant Uint := Scope_Depth (Subp);
+
+ begin
+ if Static then
+ return (S => True, U => Static_Level);
+ else
+ return (S => False,
+ N => Offset_Static_Level (Static_Level, Subp));
+ end if;
+ end;
-- Non-package bodies and statements are counted as masters
@@ -247,8 +392,7 @@ package body Accessibility is
| N_Task_Body
or else Is_Statement (Node_Par)
then
- Master_Lvl_Modifier := Master_Lvl_Modifier + 1;
-
+ Level_Modifier := Level_Modifier + 1;
end if;
Node_Par := Parent (Node_Par);
@@ -258,8 +402,17 @@ package body Accessibility is
pragma Assert (False);
- return Scope_Depth (Current_Scope) + 1;
- end Innermost_Master_Scope_Depth;
+ return Make_Level_Value (Scope_Depth (Current_Scope) + 1);
+ end Enclosing_Master_Level;
+
+ -------------------
+ -- Library_Level --
+ -------------------
+
+ function Library_Level return Level_T is
+ begin
+ return Make_Level_Value (Scope_Depth (Standard_Standard));
+ end Library_Level;
------------------------
-- Make_Level_Literal --
@@ -273,11 +426,24 @@ package body Accessibility is
return Result;
end Make_Level_Literal;
+ ----------------------
+ -- Make_Level_Value --
+ ----------------------
+
+ function Make_Level_Value (Level : Uint) return Level_T is
+ begin
+ if Static then
+ return (S => True, U => Level);
+ else
+ return (S => False, N => Make_Level_Literal (Level));
+ end if;
+ end Make_Level_Value;
+
--------------------------------------
-- Function_Call_Or_Allocator_Level --
--------------------------------------
- function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id is
+ function Function_Call_Or_Allocator_Level (N : Node_Id) return Level_T is
Prev_Par : Node_Id := Expr;
Par : Node_Id := Parent (Expr);
-- Par and Prev_Par will be used for traversing the AST, while
@@ -296,19 +462,17 @@ package body Accessibility is
if Is_Entity_Name (Name (N))
and then Is_Inherently_Limited_Type (Etype (N))
then
- return Make_Level_Literal
- (Subprogram_Access_Level (Entity (Name (N))));
+ return Subprogram_Access_Level (Entity (Name (N)));
elsif Nkind (Name (N)) = N_Explicit_Dereference
and then Is_Inherently_Limited_Type (Etype (N))
then
- return Make_Level_Literal
- (Typ_Access_Level (Etype (Prefix (Name (N)))));
+ return Type_Access_Level (Etype (Prefix (Name (N))));
-- Otherwise the accessibility level of the innermost master
else
- return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr));
+ return Enclosing_Master_Level (Expr);
end if;
-- We ignore coextensions as they cannot be implemented under the
@@ -318,12 +482,12 @@ package body Accessibility is
and then (Is_Static_Coextension (N)
or else Is_Dynamic_Coextension (N))
then
- return Make_Level_Literal (Scope_Depth (Standard_Standard));
+ return Library_Level;
-- Objects of a named access type get their level from their type
elsif Is_Named_Access_Type (Etype (N)) then
- return Make_Level_Literal (Typ_Access_Level (Etype (N)));
+ return Type_Access_Level (Etype (N));
-- Function calls in Ada 2005 and later, and anonymous allocators
@@ -339,7 +503,8 @@ package body Accessibility is
-- designated type.
if Debug_Flag_Underscore_B then
- return Make_Level_Literal (Typ_Access_Level (Etype (N)));
+ return
+ Make_Level_Value (Static_Type_Access_Level (Etype (N)));
-- For function calls the level is that of the innermost
-- master; otherwise, for allocators we get the level of
@@ -347,8 +512,7 @@ package body Accessibility is
-- calculated through the normal path of execution.
elsif Nkind (N) = N_Function_Call then
- return
- Make_Level_Literal (Innermost_Master_Scope_Depth (Expr));
+ return Enclosing_Master_Level (Expr);
end if;
end if;
@@ -360,15 +524,15 @@ package body Accessibility is
and then Nkind (N) = N_Function_Call
and then Is_Scalar_Type (Etype (N))
then
- return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr));
+ return Enclosing_Master_Level (Expr);
end if;
- -- 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.
+ -- RM 3.10.2(10.5): If the call itself defines the result of a
+ -- function F, or has an accessibility level that is tied to the
+ -- result of such a function F, then the master of the call is
+ -- that of the master of the call invoking F.
- if In_Return_Value (N) or else In_Return_Context then
+ if In_Return_Context or In_Return_Value (N) then
declare
Extra_Formal : constant Entity_Id :=
Extra_Accessibility_Of_Result (Current_Subprogram);
@@ -382,14 +546,14 @@ package body Accessibility is
-- "passed along".
if Present (Extra_Formal) and then Level = Dynamic_Level then
- return New_Occurrence_Of (Extra_Formal, Loc);
+ return (S => False,
+ N => New_Occurrence_Of (Extra_Formal, Loc));
-- Otherwise, return accessibility level of the enclosing
-- subprogram.
else
- return Make_Level_Literal
- (Subprogram_Access_Level (Current_Subprogram));
+ return Subprogram_Access_Level (Current_Subprogram);
end if;
end;
end if;
@@ -434,17 +598,17 @@ package body Accessibility is
when N_Type_Conversion =>
if Is_Named_Access_Type (Etype (Par)) then
- return
- Make_Level_Literal (Typ_Access_Level (Etype (Par)));
+ return Type_Access_Level (Etype (Par));
end if;
-- For the (static) declaration of an object, return the
-- accessibility level of the master of the object.
when N_Object_Declaration =>
- return
- Accessibility_Level
- (Defining_Identifier (Par), Object_Decl_Level);
+ return Accessibility_Level
+ (Expr => Defining_Identifier (Par),
+ Level => Object_Decl_Level,
+ Static => Static);
-- For the dynamic allocation of an object, return the
-- accessibility level of the allocator.
@@ -471,6 +635,7 @@ package body Accessibility is
return Accessibility_Level
(Expr => Name (Par),
Level => Object_Decl_Level,
+ Static => Static,
In_Return_Context => In_Return_Context);
when others =>
@@ -486,7 +651,7 @@ package body Accessibility is
-- Return the accessibility level of the innermost master
- return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr));
+ return Enclosing_Master_Level (Expr);
end if;
end Function_Call_Or_Allocator_Level;
@@ -498,6 +663,10 @@ package body Accessibility is
-- Start of processing for Accessibility_Level
begin
+ -- Make sure that we are not passed contradictory input
+
+ pragma Assert (not (Level = Dynamic_Level and then Static));
+
-- We could be looking at a reference to a formal due to the expansion
-- of entries and other cases, so obtain the renaming if necessary.
@@ -537,13 +706,13 @@ package body Accessibility is
-- The accessibility level of the literal null is the library level
when N_Null =>
- return Make_Level_Literal (Scope_Depth (Standard_Standard));
+ return Library_Level;
-- The level of an aggregate is that of the innermost master that
-- evaluates it as defined in RM 3.10.2 (10/4).
when N_Aggregate =>
- return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr));
+ return Enclosing_Master_Level (Expr);
-- The accessibility level is that of the access type, except for
-- anonymous allocators which have special rules defined in RM 3.10.2
@@ -579,9 +748,8 @@ package body Accessibility is
-- Return the level of the enclosing declaration
- return Make_Level_Literal
- (Innermost_Master_Scope_Depth
- (Enclosing_Declaration (Expr)));
+ return
+ Enclosing_Master_Level (Enclosing_Declaration (Expr));
-- Return the library level to null out the check for the Address,
-- Deref, Unchecked_Access and Unrestricted_Access attributes.
@@ -591,7 +759,7 @@ package body Accessibility is
| Name_Unchecked_Access
| Name_Unrestricted_Access
then
- return Make_Level_Literal (Scope_Depth (Standard_Standard));
+ return Library_Level;
-- For 'Old return the level of the associated entity, if any
@@ -617,18 +785,19 @@ package body Accessibility is
-- Named access types
if Is_Named_Access_Type (Etype (Pre)) then
- return Make_Level_Literal (Typ_Access_Level (Etype (Pre)));
+ return Type_Access_Level (Etype (Pre));
-- Anonymous access types
elsif Is_Entity_Name (Pre)
and then Ekind (Entity (Pre)) not in Subprogram_Kind
- and then Present (Get_Dynamic_Accessibility (Entity (Pre)))
+ and then Present (Extra_Accessibility (Entity (Pre)))
and then Level = Dynamic_Level
then
pragma Assert (Is_Anonymous_Access_Type (Etype (Pre)));
- return New_Occurrence_Of
- (Get_Dynamic_Accessibility (Entity (Pre)), Loc);
+ return (S => False,
+ N => New_Occurrence_Of
+ (Extra_Accessibility (Entity (Pre)), Loc));
-- Otherwise the level is treated in a similar way as
-- aggregates according to RM 6.1.1 (35.1/4) which concerns
@@ -637,8 +806,7 @@ package body Accessibility is
-- declaration.
else
- return Make_Level_Literal
- (Innermost_Master_Scope_Depth (Expr));
+ return Enclosing_Master_Level (Expr);
end if;
else
@@ -671,48 +839,45 @@ package body Accessibility is
and then
Wrapped_Statements (Scope (E)) =
Current_Subprogram))
- and then (In_Return_Value (Expr) or else In_Return_Context)
+ and then (In_Return_Context or else In_Return_Value (Expr))
then
- return Make_Level_Literal (Scope_Depth (Standard_Standard));
+ return Library_Level;
-- Formal parameters with an extra accessibility formal, as well
-- as stand-alone objects of an anonymous access type (SAOOAAAT).
elsif (Is_Formal (E) or else Ekind (E) in E_Constant | E_Variable)
- and then Present (Get_Dynamic_Accessibility (E))
- and then Level in Dynamic_Level | Zero_On_Dynamic_Level
+ and then Present (Extra_Accessibility (E))
+ and then Level in Dynamic_Level | Library_On_Dynamic_Level
then
- if Level = Zero_On_Dynamic_Level then
- return Make_Level_Literal (Scope_Depth (Standard_Standard));
- end if;
+ -- Return the library level if explicitly requested
+
+ if Level = Library_On_Dynamic_Level then
+ return Library_Level;
-- No_Dynamic_Accessibility_Checks restriction override for
-- alternative accessibility model.
- if Allow_Alt_Model
+ elsif Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (E)
then
-- In the alternative model the level is that of the
-- designated type entity's context.
if Debug_Flag_Underscore_B then
- return Make_Level_Literal (Typ_Access_Level (Etype (E)));
-
- -- Otherwise the level depends on the entity's context
-
- elsif Is_Formal (E) then
- return Make_Level_Literal
- (Subprogram_Access_Level
- (Enclosing_Subprogram (E)));
+ return Make_Level_Value
+ (Static_Type_Access_Level (Etype (E)));
else
- return Make_Level_Literal
- (Scope_Depth (Enclosing_Dynamic_Scope (E)));
+ return Make_Level_Value (Static_Local_Access_Level (E));
end if;
- end if;
-- Return the dynamic level in the normal case
- return New_Occurrence_Of (Get_Dynamic_Accessibility (E), Loc);
+ else
+ return
+ (S => False,
+ N => New_Occurrence_Of (Extra_Accessibility (E), Loc));
+ end if;
-- Return the library level for formal parameters or stand-alone
-- objects of an anonymous access type without extra accessibility
@@ -723,21 +888,24 @@ package body Accessibility is
elsif (Is_Formal (E) or else Ekind (E) in E_Constant | E_Variable)
and then Is_Anonymous_Access_Type (Etype (E))
and then not Is_Local_Anonymous_Access (Etype (E))
- and then Level in Dynamic_Level | Zero_On_Dynamic_Level
+ and then Level in Dynamic_Level | Library_On_Dynamic_Level
then
- return Make_Level_Literal (Scope_Depth (Standard_Standard));
+ return Library_Level;
-- Initialization procedures have a special extra accessibility
-- parameter associated with the level at which the object
-- being initialized exists
- elsif Ekind (E) = E_Record_Type
+ elsif Level = Dynamic_Level
+ and then Ekind (E) = E_Record_Type
and then Is_Limited_Record (E)
and then Current_Scope = Init_Proc (E)
and then Present (Init_Proc_Level_Formal (Current_Scope))
then
- return New_Occurrence_Of
- (Init_Proc_Level_Formal (Current_Scope), Loc);
+ return
+ (S => False,
+ N => New_Occurrence_Of
+ (Init_Proc_Level_Formal (Current_Scope), Loc));
-- Current instance of the type is deeper than that of the type
-- according to RM 3.10.2 (21).
@@ -750,12 +918,20 @@ package body Accessibility is
and then No_Dynamic_Accessibility_Checks_Enabled (E)
and then Debug_Flag_Underscore_B
then
- return Make_Level_Literal (Typ_Access_Level (E));
+ return Make_Level_Value (Static_Type_Access_Level (E));
end if;
-- Normal path
- return Make_Level_Literal (Typ_Access_Level (E) + 1);
+ if Static then
+ return (S => True, U => Static_Type_Access_Level (E) + 1);
+ else
+ return
+ (S => False,
+ N => Make_Op_Add (Loc,
+ Left_Opnd => Dynamic_Type_Access_Level (E),
+ Right_Opnd => Make_Level_Literal (Uint_1)));
+ end if;
-- Move up the renamed entity or object if it came from source
-- since expansion may have created a dummy renaming under
@@ -773,7 +949,7 @@ package body Accessibility is
-- Objects of a named access type get their level from their type
elsif Is_Named_Access_Type (Etype (E)) then
- return Make_Level_Literal (Typ_Access_Level (Etype (E)));
+ return Type_Access_Level (Etype (E));
-- Check if E is an expansion-generated renaming of an iterator
-- by examining Related_Expression. If so, determine the
@@ -789,20 +965,21 @@ package body Accessibility is
and then Is_Subprogram (Scope (E))
and then Present (Init_Proc_Level_Formal (Scope (E)))
then
- return New_Occurrence_Of
- (Init_Proc_Level_Formal (Scope (E)), Loc);
+ return
+ (S => False,
+ N => New_Occurrence_Of
+ (Init_Proc_Level_Formal (Scope (E)), Loc));
-- Formal object of generic subprogram - get the level of the
-- subprogram
elsif Is_Formal_Object (E) and then Is_Subprogram (Scope (E)) then
- return Make_Level_Literal (Subprogram_Access_Level (Scope (E)));
+ return Subprogram_Access_Level (Scope (E));
- -- Normal object - get the depth of the enclosing dynamic scope
+ -- Normal object - get the local access level
else
- return Make_Level_Literal
- (Scope_Depth (Enclosing_Dynamic_Scope (E)));
+ return Local_Access_Level (E);
end if;
-- Handle indexed and selected components including the special cases
@@ -836,14 +1013,14 @@ package body Accessibility is
-- of the named access type in the prefix.
elsif Is_Named_Access_Type (Etype (Pre)) then
- return Make_Level_Literal (Typ_Access_Level (Etype (Pre)));
+ return Type_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
-- named access type.
elsif Is_Named_Access_Type (Etype (E)) then
- return Make_Level_Literal (Typ_Access_Level (Etype (E)));
+ return Type_Access_Level (Etype (E));
-- A nondiscriminant selected component where the component
-- is an anonymous access type means that its associated
@@ -885,13 +1062,13 @@ package body Accessibility is
and then No_Dynamic_Accessibility_Checks_Enabled (E)
and then Debug_Flag_Underscore_B
then
- return Make_Level_Literal (Typ_Access_Level (Etype (E)));
+ return
+ Make_Level_Value (Static_Type_Access_Level (Etype (E)));
end if;
-- Otherwise proceed normally
- return
- Make_Level_Literal (Typ_Access_Level (Etype (Prefix (E))));
+ return Type_Access_Level (Etype (Prefix (E)));
-- The accessibility calculation routine that handles function
-- calls (Function_Call_Or_Allocator_Level) assumes, in the case
@@ -915,12 +1092,12 @@ package body Accessibility is
if (Ekind (Etype (Pre)) = E_Anonymous_Access_Type
or else Has_Implicit_Dereference (Etype (Pre)))
- and then (In_Return_Value (E) or else In_Return_Context)
+ and then (In_Return_Context or else In_Return_Value (E))
then
return Function_Call_Or_Allocator_Level (Prefix (E));
end if;
- return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr));
+ return Enclosing_Master_Level (Expr);
-- Otherwise, continue recursing over the expression prefixes
@@ -932,7 +1109,7 @@ package body Accessibility is
when N_Qualified_Expression =>
if Is_Named_Access_Type (Etype (E)) then
- return Make_Level_Literal (Typ_Access_Level (Etype (E)));
+ return Type_Access_Level (Etype (E));
else
return Accessibility_Level (Expression (E));
end if;
@@ -951,7 +1128,7 @@ package body Accessibility is
-- its type.
if Is_Named_Access_Type (Etype (Pre)) then
- return Make_Level_Literal (Typ_Access_Level (Etype (Pre)));
+ return Type_Access_Level (Etype (Pre));
-- Otherwise, recurse deeper
@@ -977,13 +1154,13 @@ package body Accessibility is
-- access type.
elsif Is_Named_Access_Type (Etype (E)) then
- return Make_Level_Literal (Typ_Access_Level (Etype (E)));
+ return Type_Access_Level (Etype (E));
-- In section RM 3.10.2 (10/4) the accessibility rules for
-- aggregates and value conversions are outlined. Are these
-- followed in the case of initialization of an object ???
- -- Should use Innermost_Master_Scope_Depth ???
+ -- Should use Enclosing_Master_Level ???
else
return Accessibility_Level (Current_Scope);
@@ -993,7 +1170,7 @@ package body Accessibility is
-- expression's entity.
when others =>
- return Make_Level_Literal (Typ_Access_Level (Etype (E)));
+ return Type_Access_Level (Etype (E));
end case;
end Accessibility_Level;
@@ -1024,7 +1201,8 @@ package body Accessibility is
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)
+ (Static_Type_Access_Level (Etype (Exp))
+ > Static_Type_Access_Level (PtrT)
or else
(Is_Class_Wide_Type (Etype (Exp))
and then Scope (PtrT) /= Current_Scope))
@@ -1173,7 +1351,7 @@ package body Accessibility is
Cond :=
Make_Op_Gt (Loc,
Left_Opnd => Cond,
- Right_Opnd => Accessibility_Level (N, Dynamic_Level));
+ Right_Opnd => Dynamic_Accessibility_Level (N));
-- Due to the complexity and side effects of the check, utilize an if
-- statement instead of the regular Program_Error circuitry.
@@ -1251,8 +1429,8 @@ package body Accessibility is
Condition =>
Make_Op_Gt (Loc,
Left_Opnd =>
- Accessibility_Level
- (Exp, Dynamic_Level, In_Return_Context => True),
+ Dynamic_Accessibility_Level
+ (Exp, In_Return_Context => True),
Right_Opnd => New_Occurrence_Of
(Extra_Accessibility_Of_Result (Func), Loc)),
Reason => PE_Accessibility_Check_Failed),
@@ -1283,8 +1461,8 @@ package body Accessibility is
N_Type_Conversion | N_Unchecked_Type_Conversion
or else (Is_Entity_Name (Exp)
and then Is_Formal (Entity (Exp)))
- or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
- Subprogram_Access_Level (Func))
+ or else Static_Type_Access_Level (Etype (Exp))
+ > Static_Subprogram_Access_Level (Func))
then
declare
Tag_Node : Node_Id;
@@ -1364,9 +1542,7 @@ package body Accessibility is
Condition =>
Make_Op_Gt (Loc,
Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Subprogram_Access_Level (Func))),
+ Right_Opnd => Dynamic_Subprogram_Access_Level (Func)),
Reason => PE_Accessibility_Check_Failed),
Suppress => Access_Check);
end;
@@ -1426,8 +1602,8 @@ package body Accessibility is
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
- Left_Opnd => Accessibility_Level (Exp, Dynamic_Level),
- Right_Opnd => Accessibility_Level (N, Dynamic_Level)),
+ Left_Opnd => Dynamic_Accessibility_Level (Exp),
+ Right_Opnd => Dynamic_Accessibility_Level (N)),
Reason => PE_Accessibility_Check_Failed),
Suppress => Access_Check);
@@ -1456,9 +1632,8 @@ package body Accessibility is
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)),
+ Left_Opnd => Dynamic_Accessibility_Level (Discr_Exp),
+ Right_Opnd => Dynamic_Accessibility_Level (N)),
Reason => PE_Accessibility_Check_Failed),
Suppress => Access_Check);
end if;
@@ -1648,14 +1823,14 @@ package body Accessibility is
-- extra access level object and when accessibility checks are enabled.
if Present (Param_Ent)
- and then Present (Get_Dynamic_Accessibility (Param_Ent))
+ and then Present (Extra_Accessibility (Param_Ent))
and then not Accessibility_Checks_Suppressed (Param_Ent)
and then not Accessibility_Checks_Suppressed (Typ)
then
-- Obtain the parameter's accessibility level
Param_Level :=
- New_Occurrence_Of (Get_Dynamic_Accessibility (Param_Ent), Loc);
+ New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
-- Use the dynamic accessibility parameter for the function's result
-- when one has been created instead of statically referring to the
@@ -1684,8 +1859,7 @@ package body Accessibility is
-- Otherwise get the type's accessibility level normally
else
- Type_Level :=
- Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
+ Type_Level := Dynamic_Type_Access_Level (Typ, Deepest => True);
end if;
-- Raise Program_Error if the accessibility level of the access
@@ -1964,9 +2138,8 @@ package body Accessibility is
-- Apply the RM 3.10.2(12.4) rule to formal parameters
elsif Is_Entity_Name (Unqual) and then Is_Formal (Entity (Unqual)) then
- if Static_Accessibility_Level
- (Unqual, Zero_On_Dynamic_Level, In_Return_Context => True)
- > Subprogram_Access_Level (Scope_Id)
+ if Static_Accessibility_Level (Unqual, In_Return_Context => True)
+ > Static_Subprogram_Access_Level (Scope_Id)
then
Accessibility_Error;
end if;
@@ -2216,8 +2389,8 @@ package body Accessibility is
and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type
and then
Static_Accessibility_Level
- (Assoc_Expr, Zero_On_Dynamic_Level, In_Return_Context => True)
- > Subprogram_Access_Level (Scope_Id)
+ (Assoc_Expr, In_Return_Context => True)
+ > Static_Subprogram_Access_Level (Scope_Id)
then
Accessibility_Error;
end if;
@@ -2240,46 +2413,89 @@ package body Accessibility is
end loop;
end Check_Return_Construct_Accessibility;
- -------------------------------
- -- Deepest_Type_Access_Level --
- -------------------------------
+ ---------------------------------
+ -- Dynamic_Accessibility_Level --
+ ---------------------------------
- function Deepest_Type_Access_Level
- (Typ : Entity_Id;
- Allow_Alt_Model : Boolean := True) return Uint
+ function Dynamic_Accessibility_Level
+ (Expr : Node_Id;
+ In_Return_Context : Boolean := False;
+ Allow_Alt_Model : Boolean := True) return Node_Id
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.
+ return
+ Accessibility_Level (Expr => Expr,
+ Level => Dynamic_Level,
+ Static => False,
+ In_Return_Context => In_Return_Context,
+ Allow_Alt_Model => Allow_Alt_Model).N;
+ end Dynamic_Accessibility_Level;
- if Allow_Alt_Model
- and then No_Dynamic_Accessibility_Checks_Enabled (Typ)
- then
- return Type_Access_Level (Typ, Allow_Alt_Model);
- end if;
+ --------------------------------
+ -- Dynamic_Local_Access_Level --
+ --------------------------------
- -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
- -- access type.
+ function Dynamic_Local_Access_Level (E : Entity_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (E);
+ Static_Level : constant Uint := Static_Local_Access_Level (E);
+ Subp : constant Entity_Id := Enclosing_Subprogram (E);
- return
- Scope_Depth (Enclosing_Dynamic_Scope
- (Defining_Identifier
- (Associated_Node_For_Itype (Typ))));
+ begin
+ if Present (Subp) then
+ return Offset_Static_Level (Static_Level, Subp);
+ else
+ return Make_Integer_Literal (Loc, Static_Level);
+ end if;
+ end Dynamic_Local_Access_Level;
+
+ -------------------------------------
+ -- Dynamic_Subprogram_Access_Level --
+ -------------------------------------
+
+ function Dynamic_Subprogram_Access_Level (Subp : Entity_Id) return Node_Id
+ is
+ begin
+ if Present (Alias (Subp)) then
+ return Dynamic_Subprogram_Access_Level (Alias (Subp));
+ else
+ return Dynamic_Local_Access_Level (Subp);
+ end if;
+ end Dynamic_Subprogram_Access_Level;
+
+ -------------------------------
+ -- Dynamic_Type_Access_Level --
+ -------------------------------
- -- For generic formal type, return Int'Last (infinite).
- -- See comment preceding Is_Generic_Type call in Type_Access_Level.
+ function Dynamic_Type_Access_Level
+ (Typ : Entity_Id;
+ Deepest : Boolean := False;
+ Allow_Alt_Model : Boolean := True) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Val : constant Type_Level_T :=
+ Type_Access_Level (Typ, Deepest, Allow_Alt_Model, Empty);
- elsif Is_Generic_Type (Root_Type (Typ)) then
- return UI_From_Int (Int'Last);
+ begin
+ if Present (Val.Base) then
+ declare
+ Dynamic_Level : constant Node_Id :=
+ Dynamic_Local_Access_Level (Val.Base);
+
+ begin
+ if Val.Offset /= Uint_0 then
+ return
+ Make_Op_Add (Loc,
+ Left_Opnd => Dynamic_Level,
+ Right_Opnd => Make_Integer_Literal (Loc, Val.Offset));
+ else
+ return Dynamic_Level;
+ end if;
+ end;
else
- return Type_Access_Level (Typ, Allow_Alt_Model);
+ return Make_Integer_Literal (Loc, Val.Offset);
end if;
- end Deepest_Type_Access_Level;
+ end Dynamic_Type_Access_Level;
-------------------------
-- Extra_Accessibility --
@@ -2300,30 +2516,6 @@ package body Accessibility is
end if;
end Extra_Accessibility;
- -------------------------------
- -- Get_Dynamic_Accessibility --
- -------------------------------
-
- function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id is
- begin
- -- When minimum accessibility is set for E then we utilize it - except
- -- in a few edge cases like the expansion of select statements where
- -- generated subprogram may attempt to unnecessarily use a minimum
- -- accessibility object declared outside of scope.
-
- -- To avoid these situations where expansion may get complex we verify
- -- that the minimum accessibility object is within scope.
-
- if Is_Formal (E)
- and then Present (Minimum_Accessibility (E))
- and then In_Open_Scopes (Scope (Minimum_Accessibility (E)))
- then
- return Minimum_Accessibility (E);
- end if;
-
- return Extra_Accessibility (E);
- end Get_Dynamic_Accessibility;
-
-----------------------
-- Has_Access_Values --
-----------------------
@@ -2592,6 +2784,41 @@ package body Accessibility is
end if;
end Needs_Result_Accessibility_Level;
+ -------------------------
+ -- Offset_Static_Level --
+ -------------------------
+
+ -- An alternate, more sophisticated formula could be:
+ --
+ -- if Extra_Accessibility (Subp) > Static_Accessibility (Subp)
+ -- then Level + Extra_Accessibility (Subp) - Static_Accessibility (Subp)
+ -- else Level
+ --
+ -- and would yield more progressive dynamic levels in call chains, but it
+ -- would complicate the run-time computation and not really buy anything.
+
+ function Offset_Static_Level
+ (Level : Uint;
+ Subp : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Subp);
+
+ begin
+ pragma Assert (Is_Subprogram (Subp));
+
+ if Present (Extra_Accessibility_Of_Subprogram (Subp)) then
+ return
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of
+ (Extra_Accessibility_Of_Subprogram (Subp), Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, Level));
+
+ else
+ return Make_Integer_Literal (Loc, Level);
+ end if;
+ end Offset_Static_Level;
+
------------------------------------------
-- Prefix_With_Safe_Accessibility_Level --
------------------------------------------
@@ -2664,45 +2891,102 @@ package body Accessibility is
return True;
end Prefix_With_Safe_Accessibility_Level;
- -----------------------------
- -- Subprogram_Access_Level --
- -----------------------------
-
- function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
- begin
- if Present (Alias (Subp)) then
- return Subprogram_Access_Level (Alias (Subp));
- else
- return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
- end if;
- end Subprogram_Access_Level;
-
--------------------------------
-- Static_Accessibility_Level --
--------------------------------
function Static_Accessibility_Level
(Expr : Node_Id;
- Level : Static_Accessibility_Level_Kind;
+ Object_Decl_Level : Boolean := False;
In_Return_Context : Boolean := False) return Uint
is
+ Level : constant Accessibility_Level_Kind :=
+ (if Object_Decl_Level
+ then Accessibility.Object_Decl_Level
+ else Library_On_Dynamic_Level);
+
begin
- return Intval (Accessibility_Level (Expr, Level, In_Return_Context));
+ return
+ Accessibility_Level (Expr => Expr,
+ Level => Level,
+ Static => True,
+ In_Return_Context => In_Return_Context).U;
end Static_Accessibility_Level;
+ -------------------------------
+ -- Static_Local_Access_Level --
+ -------------------------------
+
+ function Static_Local_Access_Level (E : Entity_Id) return Uint is
+ begin
+ return Scope_Depth (Enclosing_Dynamic_Scope (E));
+ end Static_Local_Access_Level;
+
+ ------------------------------------
+ -- Static_Subprogram_Access_Level --
+ ------------------------------------
+
+ function Static_Subprogram_Access_Level (Subp : Entity_Id) return Uint is
+ begin
+ if Present (Alias (Subp)) then
+ return Static_Subprogram_Access_Level (Alias (Subp));
+ else
+ return Static_Local_Access_Level (Subp);
+ end if;
+ end Static_Subprogram_Access_Level;
+
+ ------------------------------
+ -- Static_Type_Access_Level --
+ ------------------------------
+
+ function Static_Type_Access_Level
+ (Typ : Entity_Id;
+ Deepest : Boolean := False;
+ Allow_Alt_Model : Boolean := True;
+ Assoc_Node : Node_Id := Empty) return Uint
+ is
+ Val : constant Type_Level_T :=
+ Type_Access_Level (Typ, Deepest, Allow_Alt_Model, Assoc_Node);
+
+ begin
+ if Present (Val.Base) then
+ return Static_Local_Access_Level (Val.Base) + Val.Offset;
+ else
+ return Val.Offset;
+ end if;
+ end Static_Type_Access_Level;
+
-----------------------
-- Type_Access_Level --
-----------------------
function Type_Access_Level
(Typ : Entity_Id;
- Allow_Alt_Model : Boolean := True;
- Assoc_Ent : Entity_Id := Empty) return Uint
+ Deepest : Boolean := False;
+ Allow_Alt_Model : Boolean := True;
+ Assoc_Node : Node_Id := Empty) return Type_Level_T
is
Btyp : Entity_Id := Base_Type (Typ);
Def_Ent : Entity_Id;
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
+ and then Deepest
+
+ -- No_Dynamic_Accessibility_Checks override for alternative
+ -- accessibility model.
+
+ and then not (Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (Typ))
+ then
+ -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
+ -- access type.
+
+ return
+ (Defining_Identifier (Associated_Node_For_Itype (Typ)), Uint_0);
+
-- 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
@@ -2711,7 +2995,7 @@ package body Accessibility is
-- the cases of access parameters, return objects of an anonymous access
-- type, and, in Ada 95, access discriminants of limited types.
- if Is_Access_Type (Btyp) then
+ elsif Is_Access_Type (Btyp) then
if Ekind (Btyp) = E_Anonymous_Access_Type then
-- No_Dynamic_Accessibility_Checks restriction override for
-- alternative accessibility model.
@@ -2727,16 +3011,18 @@ package body Accessibility is
(Designated_Type (Btyp), Allow_Alt_Model);
end if;
- -- When an anonymous access type's Assoc_Ent is specified,
+ -- When an anonymous access type's Assoc_Node is specified,
-- calculate the result based on the general accessibility
-- level routine.
-- We would like to use Associated_Node_For_Itype here instead,
-- but in some cases it is not fine grained enough ???
- if Present (Assoc_Ent) then
- return Static_Accessibility_Level
- (Assoc_Ent, Object_Decl_Level);
+ if Present (Assoc_Node) then
+ return
+ (Empty,
+ Static_Accessibility_Level
+ (Assoc_Node, Object_Decl_Level => True));
end if;
-- Otherwise take the context of the anonymous access type into
@@ -2749,10 +3035,9 @@ package body Accessibility is
(Associated_Node_For_Itype (Typ));
if Present (Def_Ent) then
- -- When the defining entity is a subprogram then we know the
- -- anonymous access type Typ has been generated to either
- -- describe an anonymous access type formal or an anonymous
- -- access result type.
+ -- When the defining entity is a subprogram, then we know
+ -- that the anonymous access type Typ has been generated
+ -- for either an access formal or an access result.
-- Since we are only interested in the formal case, avoid
-- the anonymous access result type.
@@ -2762,20 +3047,23 @@ package body Accessibility is
and then Etype (Def_Ent) = Typ)
then
-- When the type comes from an anonymous access
- -- parameter, the level is that of the subprogram
- -- declaration.
+ -- parameter, the level is that of the parameter
+ -- in the called subprogram.
- return Scope_Depth (Def_Ent);
+ if In_Open_Scopes (Def_Ent) then
+ return (First_Formal (Def_Ent), Uint_0);
+
+ -- The level is the deepest possible in the caller
+
+ else
+ return (Empty, UI_From_Int (Int'Last));
+ end if;
-- When the type is an access discriminant, the level is
-- that of the type.
elsif Ekind (Def_Ent) = E_Discriminant then
- return Scope_Depth
- (if Present (Full_View (Scope (Def_Ent))) then
- Full_View (Scope (Def_Ent))
- else
- Scope (Def_Ent));
+ return (Scope (Def_Ent), Uint_0);
end if;
end if;
@@ -2785,7 +3073,7 @@ package body Accessibility is
-- fail static accessibility checks.
elsif not Is_Local_Anonymous_Access (Typ) then
- return Scope_Depth (Standard_Standard);
+ return (Empty, Scope_Depth (Standard_Standard));
-- If this is a return object, the accessibility level is that of
-- the result subtype of the enclosing function. The test here is
@@ -2829,30 +3117,30 @@ package body Accessibility is
and then Nkind (Associated_Node_For_Itype (Typ)) =
N_Discriminant_Specification
then
- return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
+ return (Btyp, Uint_1);
end if;
end if;
-- Return library level for a generic formal type. This is done because
- -- RM(10.3.2) says that "The statically deeper relationship does not
- -- apply to ... a descendant of a generic formal type". Rather than
+ -- RM 3.10.2(19.4) says that "The statically deeper relationship does
+ -- not apply to ... a descendant of a generic formal type". Rather than
-- checking at each point where a static accessibility check is
-- performed to see if we are dealing with a formal type, this rule is
- -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
- -- return extreme values for a formal type; Deepest_Type_Access_Level
- -- returns Int'Last. By calling the appropriate function from among the
- -- two, we ensure that the static accessibility check will pass if we
- -- happen to run into a formal type. More specifically, we should call
- -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
- -- call occurs as part of a static accessibility check and the error
- -- case is the case where the type's level is too shallow (as opposed
- -- to too deep).
+ -- implemented by returning extreme values for a formal type depending
+ -- on the Deepest parameter. More specifically, Deepest should be passed
+ -- as True whenever the call occurs as part of a static accessibility
+ -- check and the error case is the case where the type's level is too
+ -- shallow (as opposed to too deep).
if Is_Generic_Type (Root_Type (Btyp)) then
- return Scope_Depth (Standard_Standard);
+ if Deepest then
+ return (Empty, UI_From_Int (Int'Last));
+ else
+ return (Empty, Scope_Depth (Standard_Standard));
+ end if;
end if;
- return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
+ return (Btyp, Uint_0);
end Type_Access_Level;
end Accessibility;
diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads
index 6790864d7d7..a162371b436 100644
--- a/gcc/ada/accessibility.ads
+++ b/gcc/ada/accessibility.ads
@@ -23,7 +23,7 @@
-- --
------------------------------------------------------------------------------
--- Accessibility level and check generation routines
+-- Accessibility level calculation and check generation routines
with Types; use Types;
with Uintp; use Uintp;
@@ -34,43 +34,6 @@ package Accessibility is
-- Error, or warning within an instance, if the static accessibility
-- rules of 3.10.2 are violated.
- type Accessibility_Level_Kind is
- (Dynamic_Level, Object_Decl_Level, Zero_On_Dynamic_Level);
- -- Captures the different modes in which an accessibility level could be
- -- obtained for a given expression. In the context of Accessibility_Level
- -- function, Accessibility_Level_Kind signals what type of accessibility
- -- level to obtain.
-
- -- When Level is Dynamic_Level, a defining identifier associated with an
- -- access parameter, an access result, or an SAOOAAAT, may be returned,
- -- and an N_Integer_Literal node in the other cases.
-
- -- When Level is Object_Decl_Level, an N_Integer_Literal node whose value
- -- is the level of the declaration of the object is returned in the cases
- -- where Dynamic_Level returns a defining identifier; in the other cases,
- -- the same N_Integer_Literal node as Dynamic_Level is returned.
-
- -- When Level is Zero_On_Dynamic_Level, an N_Integer_Literal node whose
- -- value is zero (i.e. that of the library level) is returned in the cases
- -- where Dynamic_Level returns a defining identifier; in the other cases,
- -- the same N_Integer_Literal node as Dynamic_Level is returned.
-
- function Accessibility_Level
- (Expr : Node_Id;
- Level : Accessibility_Level_Kind;
- 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 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.
-
procedure Apply_Accessibility_Check_For_Class_Wide_Allocator
(N : Node_Id;
Exp : Node_Id;
@@ -130,17 +93,44 @@ package Accessibility is
-- Apply legality rules of 6.5(5.9) and 6.8(5) to the access discriminants
-- of an identifier or aggregate in a return statement.
- function Deepest_Type_Access_Level
+ function Dynamic_Accessibility_Level
+ (Expr : Node_Id;
+ In_Return_Context : Boolean := False;
+ Allow_Alt_Model : Boolean := True) return Node_Id;
+ -- Return the dynamic accessibility level of a given expression Expr, i.e.
+ -- the accessibility level that is defined by the language in RM 3.10.2(3)
+ -- as a value "reflect[ing] the run-time nesting of masters".
+
+ -- In_Return_Context forces the level calculation to be carried out as if
+ -- Expr was an operative constituent of a return value; when it is False,
+ -- the function computes whether that is the case or not.
+
+ -- The Allow_Alt_Model parameter allows the alternative level calculation
+ -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
+ function Dynamic_Local_Access_Level (E : Entity_Id) return Node_Id;
+ -- Return the dynamic accessibility level of the declaration of E. This is
+ -- the scope depth of the enclosing dynamic scope of E, offsetted by the
+ -- extra accessibility level of the enclosing subprogram of E if it exists.
+
+ function Dynamic_Subprogram_Access_Level (Subp : Entity_Id) return Node_Id;
+ -- Return the dynamic accessibility level of Subp, which is the level of
+ -- the innermost master of the declaration of Subp (modulo renaming) and,
+ -- in particular, is *not* the level of the entities declared within Subp.
+ -- It is used to enforce the accessibility rules for access-to-subprogram
+ -- types, results of function calls, and formal objects of generic units.
+
+ function Dynamic_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
- -- accessibility level of the object may take on values in a range. The low
- -- bound of that range is returned by Type_Access_Level; this function
- -- yields the high bound of that range. Also differs from Type_Access_Level
- -- in the case of a descendant of a generic formal type (returns Int'Last
- -- instead of 0).
+ Deepest : Boolean := False;
+ Allow_Alt_Model : Boolean := True) return Node_Id;
+ -- Return the dynamic accessibility level of Typ
+
+ -- When Deepest is True, and Typ is that of an Ada 2012 stand-alone object
+ -- of an anonymous access type, then return the dynamic accessibility level
+ -- of the declaration of the object instead of the library level; moreover,
+ -- in the case of a descendant of a generic formal type, return Int'Last
+ -- instead of the library level.
-- The Allow_Alt_Model parameter allows the alternative level calculation
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
@@ -149,10 +139,6 @@ package Accessibility is
-- Same as Extra_Accessibility_Of_Object in Einfo, but looks through object
-- renamings per the RM 3.10.2(8) rule.
- function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id;
- -- Obtain the accessibility level for a given entity formal taking into
- -- account both extra and minimum accessibility.
-
function Has_Access_Values (T : Entity_Id) return Boolean;
-- Returns true if the underlying type of T is an access type, or has a
-- component (at any recursive level) that is an access type. This is a
@@ -194,38 +180,53 @@ package Accessibility is
-- of a value conversion is guaranteed to not create a new object,
-- accessibility rules are defined as if it might.
- subtype Static_Accessibility_Level_Kind
- is Accessibility_Level_Kind range Object_Decl_Level
- .. Zero_On_Dynamic_Level;
- -- Restrict the reange of Accessibility_Level_Kind to be non-dynamic for
- -- use in the static version of Accessibility_Level below.
-
function Static_Accessibility_Level
(Expr : Node_Id;
- Level : Static_Accessibility_Level_Kind;
+ Object_Decl_Level : Boolean := False;
In_Return_Context : Boolean := False) return Uint;
- -- Overloaded version of Accessibility_Level which returns a universal
- -- integer for use in compile-time checking. Note: Level is restricted to
- -- be non-dynamic.
-
- function Subprogram_Access_Level (Subp : Entity_Id) return Uint;
- -- Return the accessibility level of Subp. Note that this is the level of
+ -- Return the static accessibility level of a given expression Expr, i.e.
+ -- an integer reflecting the compile-time nesting of master constructs,
+ -- for use in static accessibility checks.
+
+ -- If Object_Decl_Level is True, then return the static accessibility level
+ -- of the *declaration* of the object in the cases where that of the object
+ -- itself is not defined, i.e. access parameters and Ada 2012's stand-alone
+ -- objects of an anonymous access type (RM 3.10.2(19.1-2)). If it is False,
+ -- then return the library level in these cases.
+
+ -- In_Return_Context forces the level calculation to be carried out as if
+ -- Expr was an operative constituent of a return value; when it is False,
+ -- the function computes whether that is the case or not.
+
+ function Static_Local_Access_Level (E : Entity_Id) return Uint;
+ -- Return the static accessibility level of the declaration of E. This is
+ -- the scope depth of the enclosing dynamic scope of E.
+
+ function Static_Subprogram_Access_Level (Subp : Entity_Id) return Uint;
+ -- Return the static accessibility level of Subp, which is the level of
-- the innermost master of the declaration of Subp (modulo renaming) and,
-- in particular, is *not* the level of the entities declared within Subp.
-- It is used to enforce the accessibility rules for access-to-subprogram
-- types, results of function calls, and formal objects of generic units.
- function Type_Access_Level
+ function Static_Type_Access_Level
(Typ : Entity_Id;
- Allow_Alt_Model : Boolean := True;
- Assoc_Ent : Entity_Id := Empty) return Uint;
- -- Return the accessibility level of Typ
+ Deepest : Boolean := False;
+ Allow_Alt_Model : Boolean := True;
+ Assoc_Node : Node_Id := Empty) return Uint;
+ -- Return the static accessibility level of Typ
+
+ -- When Deepest is True, and Typ is that of an Ada 2012 stand-alone object
+ -- of an anonymous access type, then return the static accessibility level
+ -- of the declaration of the object instead of the library level; moreover,
+ -- in the case of a descendant of a generic formal type, return Int'Last
+ -- instead of the library level.
-- The Allow_Alt_Model parameter allows the alternative level calculation
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
- -- Assoc_Ent allows for the optional specification of the entity associated
- -- with Typ. This gets utilized mostly for anonymous access type
- -- processing, where context matters in interpreting Typ's level.
+ -- Assoc_Node allows for the optional specification of a node associated
+ -- with Typ. This is used only for anonymous access types where the context
+ -- matters in interpreting Typ's level.
end Accessibility;
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 99ad2cd5d56..0c75a24d395 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -1530,9 +1530,10 @@ package body Contracts is
Body_Decl : constant Entity_Id := Unit_Declaration_Node (Body_Id);
Loc : constant Source_Ptr := Sloc (Body_Decl);
Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
- Subp_Id : Entity_Id;
- Ret_Type : Entity_Id;
+ Extra_Decl : Node_Id;
+ Ret_Type : Entity_Id;
+ Subp_Id : Entity_Id;
Wrapper_Id : Entity_Id;
Wrapper_Body : Node_Id;
Wrapper_Spec : Node_Id;
@@ -1619,6 +1620,16 @@ package body Contracts is
Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
end if;
+ -- Do not move the declaration of the Extra_Accessibility_Of_Subprogram
+ -- constant, if any, since it really belongs in the original subprogram.
+
+ if Present (Extra_Accessibility_Of_Subprogram (Subp_Id)) then
+ Extra_Decl :=
+ Declaration_Node (Extra_Accessibility_Of_Subprogram (Subp_Id));
+ Remove (Extra_Decl);
+ Prepend_To (Decls, Extra_Decl);
+ end if;
+
-- Create the wrapper body using Body_Id's statements and declarations
Wrapper_Body :=
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index ea563109418..73d684890ee 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1280,6 +1280,18 @@ package Einfo is
-- and the Extra_Accessibility_Of_Result field of the function points to
-- the entity for this extra formal.
+-- Extra_Accessibility_Of_Subprogram
+-- Defined in (non-generic) subprograms. Normally Empty, but if expansion
+-- is active, and the subprogram has either at least one formal parameter
+-- with Extra_Accessibility_Of_Object, or Extra_Accessibility_Of_Result,
+-- or its parent subprogram has Extra_Accessibility_Of_Subprogram, then
+-- a local constant of type Natural is created in the subprogram, whose
+-- initialization expression is the maximum of all the values mentioned
+-- above, and the Extra_Accessibility_Of_Subprogram points to the entity.
+-- It is used to offset the static nesting depth of the local entities,
+-- both objects, subprograms, and types declared in the subprogram, for
+-- the computation of the dynamic accessibility level of these entities.
+
-- Extra_Constrained
-- Defined in formal parameters in the non-generic case. Normally Empty,
-- but if expansion is active and a parameter is one for which a dynamic
@@ -3725,14 +3737,6 @@ package Einfo is
-- is also set (to the default value of zero = Default_Mechanism) in a
-- subprogram body entity but not used in this context.
--- Minimum_Accessibility
--- Defined in formal parameters in the non-generic case. Normally Empty,
--- but if expansion is active, and a parameter exists for which a
--- dynamic accessibility check is required, then an object is generated
--- within such a subprogram representing the accessibility level of the
--- subprogram or the formal's Extra_Accessibility - whichever one is
--- lesser. The Minimum_Accessibility field then points to this object.
-
-- Modulus [implementation base type only]
-- Defined in modular types. Contains the modulus. For the binary case,
-- this will be a power of 2, but if Non_Binary_Modulus is set, then it
@@ -5611,7 +5615,6 @@ package Einfo is
-- Alias (non-generic case only)
-- Renamed_Entity
-- Renamed_Object $$$
- -- Extra_Accessibility_Of_Result (non-generic case only)
-- Last_Entity
-- Interface_Name
-- Scope_Depth_Value
@@ -5625,6 +5628,8 @@ package Einfo is
-- Overridden_Inherited_Operation
-- Overridden_Operation
-- Wrapped_Entity (non-generic case only)
+ -- Extra_Accessibility_Of_Result (non-generic case only)
+ -- Extra_Accessibility_Of_Subprogram (non-generic case only)
-- Extra_Formals
-- Extra_Formals_Known (non-generic case only)
-- Anonymous_Collections (non-generic case only)
@@ -5760,7 +5765,6 @@ package Einfo is
-- Default_Value
-- Protected_Formal
-- Extra_Constrained
- -- Minimum_Accessibility
-- Last_Assignment (OUT, IN-OUT only)
-- Activation_Record_Component
-- Has_Initial_Value
@@ -5829,13 +5833,14 @@ package Einfo is
-- E_Operator
-- First_Entity
-- Alias
- -- Extra_Accessibility_Of_Result
-- Last_Entity
-- Subps_Index
-- Overridden_Inherited_Operation
-- Overridden_Operation
-- Linker_Section_Pragma
-- Contract
+ -- Extra_Accessibility_Of_Result
+ -- Extra_Accessibility_Of_Subprogram
-- Extra_Formals
-- Extra_Formals_Known
-- Import_Pragma
@@ -5992,6 +5997,7 @@ package Einfo is
-- Overridden_Inherited_Operation
-- Overridden_Operation (never for init proc)
-- Wrapped_Entity (non-generic case only)
+ -- Extra_Accessibility_Of_Subprogram (non-generic case only)
-- Extra_Formals
-- Extra_Formals_Known (non-generic case only)
-- Anonymous_Collections (non-generic case only)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 7f785c32907..da302cb048c 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@@ -4059,19 +4060,6 @@ package body Exp_Aggr is
function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean
is
-
- function SDO (E : Entity_Id) return Uint;
- -- Return the Scope Depth Of the enclosing dynamic scope of E
-
- ---------
- -- SDO --
- ---------
-
- function SDO (E : Entity_Id) return Uint is
- begin
- return Scope_Depth (Enclosing_Dynamic_Scope (E));
- end SDO;
-
-- Start of processing for Check_Component
begin
@@ -4149,7 +4137,9 @@ package body Exp_Aggr is
else
return Present (Target_Object)
and then not Is_Formal (Target_Object)
- and then SDO (Target_Object) >= SDO (Entity (C));
+ and then
+ Static_Local_Access_Level (Target_Object)
+ >= Static_Local_Access_Level (Entity (C));
end if;
-- For a renamed object, recurse
@@ -4175,7 +4165,9 @@ package body Exp_Aggr is
-- is at most as deeply nested as the component.
elsif Is_Formal (Target_Object) then
- return SDO (Target_Object) <= SDO (Entity (C));
+ return
+ Static_Local_Access_Level (Target_Object)
+ <= Static_Local_Access_Level (Entity (C));
-- For distinct stand-alone objects, this is safe
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 6ed2de30cb8..a30c19beb94 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -2613,9 +2613,7 @@ package body Exp_Attr is
Name_Req => True)),
Attribute_Name => Name_Tag)),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Type_Access_Level (P_Type))),
+ Right_Opnd => Dynamic_Type_Access_Level (P_Type)),
Then_Statements =>
New_List (Make_Raise_Statement (Loc,
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index de771f02568..5372b8a7435 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -2789,7 +2789,7 @@ package body Exp_Ch3 is
Selector_Name =>
Make_Identifier (Loc, Name_uInit_Level),
Explicit_Actual_Parameter =>
- Accessibility_Level (Id_Ref, Dynamic_Level)));
+ Dynamic_Accessibility_Level (Id_Ref)));
end if;
Append_To (Res,
@@ -3352,7 +3352,10 @@ package body Exp_Ch3 is
-- Create an extra accessibility parameter to capture the level of
-- the object being initialized when its type is a limited record.
- if Is_Limited_Record (Rec_Type) then
+ if Is_Limited_Record (Rec_Type)
+ and then not Is_RTE (Rec_Type, RE_Activation_Chain)
+ and then not Is_RTE (Rec_Type, RE_Finalization_Master)
+ then
Append_To (Parameters,
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier
@@ -8753,7 +8756,7 @@ package body Exp_Ch3 is
-- General case
else
- Level_Expr := Accessibility_Level (Expr, Dynamic_Level);
+ Level_Expr := Dynamic_Accessibility_Level (Expr);
end if;
Level_Decl :=
@@ -10062,8 +10065,9 @@ package body Exp_Ch3 is
if Is_Part_Of_Formal
or else Is_Part_Of_Dereference
or else
- Type_Access_Level (Def_Id)
- > Static_Accessibility_Level (Pool, Object_Decl_Level)
+ Static_Type_Access_Level (Def_Id)
+ > Static_Accessibility_Level
+ (Pool, Object_Decl_Level => True)
then
-- Generate:
-- if RSP'Class?(Def_Id) in RSPWS'Class then
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 8fa214f0185..57424bbe811 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -7211,9 +7211,9 @@ package body Exp_Ch4 is
and then Ekind (Ltyp) = E_Anonymous_Access_Type
then
declare
- New_N : Node_Id;
- Param_Level : Node_Id;
- Type_Level : Node_Id;
+ New_N : Node_Id;
+ Expr_Level : Node_Id;
+ Type_Level : Node_Id;
begin
-- When restriction No_Dynamic_Accessibility_Checks is in
@@ -7224,9 +7224,9 @@ package body Exp_Ch4 is
Rewrite (N,
New_Occurrence_Of
(Boolean_Literals
- (Static_Accessibility_Level
- (Lop, Object_Decl_Level) <=
- Type_Access_Level (Rtyp)),
+ (Static_Accessibility_Level
+ (Lop, Object_Decl_Level => True)
+ <= Static_Type_Access_Level (Rtyp)),
Loc));
Analyze_And_Resolve (N, Restyp);
@@ -7239,28 +7239,23 @@ package body Exp_Ch4 is
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
Analyze_And_Resolve (N, Restyp);
- -- Apply an accessibility check if the access object has an
- -- associated access level and when the level of the type is
- -- less deep than the level of the access parameter. This
- -- can only occur for access parameters and stand-alone
- -- objects of an anonymous access type.
+ -- Otherwise perform a dynamic accessibility test
else
- Param_Level := Accessibility_Level (Lop, Dynamic_Level);
-
- Type_Level :=
- Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
+ Expr_Level := Dynamic_Accessibility_Level (Lop);
+ Type_Level := Dynamic_Type_Access_Level (Rtyp);
-- Return True only if the accessibility level of the
-- expression entity is not deeper than the level of
- -- the tested access type.
+ -- the tested access type (RM 4.5.2(30.3)).
Rewrite (N,
Make_And_Then (Loc,
Left_Opnd => Relocate_Node (N),
- Right_Opnd => Make_Op_Le (Loc,
- Left_Opnd => Param_Level,
- Right_Opnd => Type_Level)));
+ Right_Opnd =>
+ Make_Op_Le (Loc,
+ Left_Opnd => Expr_Level,
+ Right_Opnd => Type_Level)));
Analyze_And_Resolve (N);
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 5d7c78f82f6..cf473331749 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -2868,7 +2868,7 @@ package body Exp_Ch5 is
-- when the Lhs denotes a container cursor and the Next function employs
-- an access type, because this can never result in a dangling pointer.
- if Is_Access_Type (Typ)
+ if Ekind (Typ) = E_Anonymous_Access_Type
and then Is_Entity_Name (Lhs)
and then Ekind (Entity (Lhs)) /= E_Loop_Parameter
and then Present (Extra_Accessibility (Entity (Lhs)))
@@ -2879,9 +2879,9 @@ package body Exp_Ch5 is
Condition =>
Make_Op_Gt (Loc,
Left_Opnd =>
- Accessibility_Level (Rhs, Dynamic_Level),
+ Dynamic_Accessibility_Level (Rhs),
Right_Opnd =>
- Accessibility_Level (Lhs, Object_Decl_Level)),
+ Dynamic_Type_Access_Level (Typ, Deepest => True)),
Reason => PE_Accessibility_Check_Failed));
end if;
@@ -2890,10 +2890,7 @@ package body Exp_Ch5 is
Name =>
New_Occurrence_Of (Extra_Accessibility (Entity (Lhs)), Loc),
Expression =>
- Accessibility_Level
- (Expr => Rhs,
- Level => Dynamic_Level,
- Allow_Alt_Model => False)));
+ Dynamic_Accessibility_Level (Rhs, Allow_Alt_Model => False)));
end if;
-- Case of assignment to a bit packed array element. If there is a
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 53f88968961..9d0e054b05a 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -1830,8 +1830,8 @@ package body Exp_Ch6 is
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (
Extra_Accessibility (Entity (Lhs)), Loc),
- Expression => Make_Integer_Literal (Loc,
- Type_Access_Level (E_Formal))));
+ Expression =>
+ Dynamic_Type_Access_Level (E_Formal)));
else
if Is_Access_Type (E_Formal)
@@ -2982,10 +2982,8 @@ package body Exp_Ch6 is
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Lvl, Loc),
Expression =>
- Accessibility_Level
- (Expr => Expression (Res_Assn),
- Level => Dynamic_Level,
- Allow_Alt_Model => False)));
+ Dynamic_Accessibility_Level
+ (Expression (Res_Assn), Allow_Alt_Model => False)));
end if;
end Expand_Branch;
@@ -3415,10 +3413,8 @@ package body Exp_Ch6 is
end if;
Add_Extra_Actual
- (Expr => Accessibility_Level
- (Expr => Parm_Ent,
- Level => Dynamic_Level,
- Allow_Alt_Model => False),
+ (Expr => Dynamic_Accessibility_Level
+ (Parm_Ent, Allow_Alt_Model => False),
EF => Extra_Accessibility (Formal));
end;
@@ -3458,9 +3454,8 @@ package body Exp_Ch6 is
end if;
Add_Extra_Actual
- (Expr => Accessibility_Level
- (Expr => Expression (Parent (Ent)),
- Level => Dynamic_Level,
+ (Expr => Dynamic_Accessibility_Level
+ (Expression (Parent (Ent)),
Allow_Alt_Model => False),
EF => Extra_Accessibility (Formal));
end;
@@ -3469,10 +3464,8 @@ package body Exp_Ch6 is
else
Add_Extra_Actual
- (Expr => Accessibility_Level
- (Expr => Prev,
- Level => Dynamic_Level,
- Allow_Alt_Model => False),
+ (Expr => Dynamic_Accessibility_Level
+ (Prev, Allow_Alt_Model => False),
EF => Extra_Accessibility (Formal));
end if;
end if;
@@ -3515,10 +3508,8 @@ package body Exp_Ch6 is
-- Otherwise get the level normally based on the call node
else
- Level := Accessibility_Level
- (Expr => Call_Node,
- Level => Dynamic_Level,
- Allow_Alt_Model => False);
+ Level := Dynamic_Accessibility_Level
+ (Call_Node, Allow_Alt_Model => False);
end if;
-- It may be possible that we are re-expanding an already
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index c2fc6c8a284..baf7c97ad1b 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -9612,13 +9612,14 @@ package body Exp_Ch9 is
-- end;
procedure Expand_N_Requeue_Statement (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Conc_Typ : Entity_Id;
- Concval : Node_Id;
- Ename : Node_Id;
- Enc_Subp : Entity_Id;
- Index : Node_Id;
- Old_Typ : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Conc_Typ : Entity_Id;
+ Concval : Node_Id;
+ Ename : Node_Id;
+ Enclosing : Entity_Id;
+ Index : Node_Id;
+ Old_Typ : Entity_Id;
function Build_Dispatching_Call_Equivalent return Node_Id;
-- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
@@ -10128,38 +10129,40 @@ package body Exp_Ch9 is
-- type. This will constitute our invocation source.
Old_Typ := Current_Scope;
- while Present (Old_Typ)
- and then not Is_Concurrent_Type (Old_Typ)
- loop
+ while Present (Old_Typ) and then not Is_Concurrent_Type (Old_Typ) loop
Old_Typ := Scope (Old_Typ);
end loop;
-- Obtain the innermost enclosing callable construct for use in
- -- generating a dynamic accessibility check.
-
- Enc_Subp := Current_Scope;
+ -- generating a dynamic accessibility check per RM 9.5.4(7.2).
- if Ekind (Enc_Subp) not in Entry_Kind | Subprogram_Kind then
- Enc_Subp := Enclosing_Subprogram (Enc_Subp);
- end if;
+ Enclosing := Empty;
+ for J in reverse 0 .. Scope_Stack.Last loop
+ Enclosing := Scope_Stack.Table (J).Entity;
+ exit when Is_Entry (Enclosing);
+ end loop;
- -- Generate a dynamic accessibility check on the target object
+ -- Generate a dynamic accessibility check on the target object, unless
+ -- it is a parameter of the innermost enclosing callable construct.
- Insert_Before_And_Analyze (N,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => Accessibility_Level (Name (N), Dynamic_Level),
- Right_Opnd => Make_Integer_Literal (Loc,
- Scope_Depth (Enc_Subp))),
- Reason => PE_Accessibility_Check_Failed));
+ if not Is_Entity_Name (Original_Node (Concval))
+ or else not Is_Formal (Entity (Original_Node (Concval)))
+ or else Enclosing /= Scope (Entity (Original_Node (Concval)))
+ then
+ Insert_Before_And_Analyze (N,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Dynamic_Accessibility_Level (Name (N)),
+ Right_Opnd => Dynamic_Local_Access_Level (Enclosing)),
+ Reason => PE_Accessibility_Check_Failed));
+ end if;
-- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
-- Concval.Ename where the type of Concval is class-wide concurrent
-- interface.
if Ada_Version >= Ada_2012
- and then Present (Concval)
and then Is_Class_Wide_Type (Conc_Typ)
and then Is_Concurrent_Interface (Conc_Typ)
then
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index bc2ad51c89c..299956e7bca 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -5064,7 +5064,7 @@ package body Exp_Disp is
-- TSD : Type_Specific_Data (I_Depth) :=
-- (Idepth => I_Depth,
- -- Access_Level => Type_Access_Level (Typ),
+ -- Access_Level => Dynamic_Type_Access_Level (Typ),
-- Alignment => Typ'Alignment,
-- Expanded_Name => Cstring_Ptr!(Exname'Address))
-- External_Tag => Cstring_Ptr!(Exname'Address))
@@ -5111,8 +5111,7 @@ package body Exp_Disp is
-- Access_Level
- Append_To (TSD_Aggr_List,
- Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
+ Append_To (TSD_Aggr_List, Dynamic_Type_Access_Level (Typ));
-- Alignment
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 93cfd85ed22..be9778630a5 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -538,6 +538,7 @@ package Gen_IL.Fields is
Esize,
Extra_Accessibility_Of_Object,
Extra_Accessibility_Of_Result,
+ Extra_Accessibility_Of_Subprogram,
Extra_Constrained,
Extra_Formal,
Extra_Formals,
@@ -829,7 +830,6 @@ package Gen_IL.Fields is
Materialize_Entity,
May_Inherit_Delayed_Rep_Aspects,
Mechanism,
- Minimum_Accessibility,
Modulus,
Must_Be_On_Byte_Boundary,
Must_Have_Preelab_Init,
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
index 4b73c011b2e..3a085e8c532 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -411,7 +411,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Is_Only_Out_Parameter, Flag),
Sm (Linker_Section_Pragma, Node_Id),
Sm (Mechanism, Mechanism_Type),
- Sm (Minimum_Accessibility, Node_Id),
Sm (Protected_Formal, Node_Id),
Sm (Spec_Entity, Node_Id),
Sm (Unset_Reference, Node_Id)));
@@ -977,6 +976,7 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Dynamic_Call_Helper, Node_Id),
Sm (Elaboration_Entity, Node_Id),
Sm (Elaboration_Entity_Required, Flag),
+ Sm (Extra_Accessibility_Of_Subprogram, Node_Id),
Sm (First_Entity, Node_Id),
Sm (Has_Expanded_Contract, Flag),
Sm (Has_Nested_Subprogram, Flag),
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index c61761edca8..4d145c44e14 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -12208,8 +12208,8 @@ package body Sem_Attr is
and then
(Ekind (Btyp) = E_Access_Subprogram_Type
or else Is_Local_Anonymous_Access (Btyp))
- and then Subprogram_Access_Level (Entity (P)) >
- Type_Access_Level (Btyp)
+ and then Static_Subprogram_Access_Level (Entity (P))
+ > Static_Type_Access_Level (Btyp)
then
Error_Msg_F
("subprogram must not be deeper than access type", P);
@@ -12266,8 +12266,8 @@ package body Sem_Attr is
and then Enclosing_Generic_Body (N) /=
Enclosing_Generic_Body
(Enclosing_Generic_Unit (Entity (P)))
- and then Subprogram_Access_Level (Entity (P)) =
- Type_Access_Level (Btyp)
+ and then Static_Subprogram_Access_Level (Entity (P)) =
+ Static_Type_Access_Level (Btyp)
and then Ekind (Btyp) /=
E_Anonymous_Access_Subprogram_Type
and then Ekind (Btyp) /=
@@ -12667,8 +12667,8 @@ package body Sem_Attr is
or else No_Dynamic_Acc_Checks)
and then
- Static_Accessibility_Level (P, Zero_On_Dynamic_Level)
- > Deepest_Type_Access_Level (Btyp)
+ Static_Accessibility_Level (P)
+ > Static_Type_Access_Level (Btyp, Deepest => True)
then
Accessibility_Message (N, Typ);
end if;
@@ -12688,8 +12688,8 @@ package body Sem_Attr is
-- anonymous_access_to_protected, there are no accessibility
-- checks either. Omit check entirely for Unrestricted_Access.
- elsif Static_Accessibility_Level (P, Zero_On_Dynamic_Level)
- > Deepest_Type_Access_Level (Btyp)
+ elsif Static_Accessibility_Level (P)
+ > Static_Type_Access_Level (Btyp, Deepest => True)
and then Comes_From_Source (N)
and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
and then Attr_Id /= Attribute_Unrestricted_Access
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index b2845814d30..853659b6ab0 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -8145,9 +8145,9 @@ package body Sem_Ch13 is
-- check (B)
- if Type_Access_Level (Ent)
+ if Static_Type_Access_Level (Ent)
> Static_Accessibility_Level
- (Pool, Object_Decl_Level)
+ (Pool, Object_Decl_Level => True)
then
Error_Msg_N
("subpool access type has deeper accessibility "
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 293f3376039..4893671b929 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2145,8 +2145,8 @@ package body Sem_Ch3 is
-- (Ada 2005: AI-230): Accessibility check for anonymous
-- components
- if Type_Access_Level (Etype (E)) >
- Deepest_Type_Access_Level (T)
+ if Static_Type_Access_Level (Etype (E))
+ > Static_Type_Access_Level (T, Deepest => True)
then
Error_Msg_N
("expression has deeper access level than component " &
@@ -9820,8 +9820,8 @@ package body Sem_Ch3 is
if Ada_Version >= Ada_2005 then
Check_Generic_Ancestors;
- elsif Type_Access_Level (Derived_Type) /=
- Type_Access_Level (Parent_Type)
+ elsif Static_Type_Access_Level (Derived_Type)
+ /= Static_Type_Access_Level (Parent_Type)
and then not Is_Generic_Type (Derived_Type)
then
if Is_Controlled (Parent_Type) then
@@ -18422,8 +18422,9 @@ package body Sem_Ch3 is
-- of the type.
if Scope (Root_Class_Typ) /= Scope (T)
- and then Deepest_Type_Access_Level (Root_Class_Typ)
- < Deepest_Type_Access_Level (T)
+ and then
+ Static_Type_Access_Level (Root_Class_Typ, Deepest => True)
+ < Static_Type_Access_Level (T)
then
Error_Msg_NE
("descendant of mutably tagged type cannot be deeper than"
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index a2028768c40..c4b09a22788 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -1098,8 +1098,8 @@ package body Sem_Ch6 is
if Ada_Version >= Ada_2005
and then Is_Class_Wide_Type (R_Type)
then
- if Type_Access_Level (Etype (Expr)) >
- Subprogram_Access_Level (Scope_Id)
+ if Static_Type_Access_Level (Etype (Expr))
+ > Static_Subprogram_Access_Level (Scope_Id)
then
Error_Msg_N
("level of return expression type is deeper than "
@@ -1122,8 +1122,8 @@ package body Sem_Ch6 is
if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L)
and then Is_Inherently_Limited_Type (Etype (Scope_Id))
- and then Static_Accessibility_Level (Expr, Zero_On_Dynamic_Level)
- > Subprogram_Access_Level (Scope_Id)
+ and then Static_Accessibility_Level (Expr)
+ > Static_Subprogram_Access_Level (Scope_Id)
then
-- Suppress the message in a generic, where the rewriting
-- is irrelevant.
@@ -1158,8 +1158,8 @@ package body Sem_Ch6 is
-- has no initializing expression.
elsif Ada_Version > Ada_2005 and then Is_Class_Wide_Type (R_Type) then
- if Type_Access_Level (Etype (Defining_Identifier (Obj_Decl))) >
- Subprogram_Access_Level (Scope_Id)
+ if Static_Type_Access_Level (Etype (Defining_Identifier (Obj_Decl)))
+ > Static_Subprogram_Access_Level (Scope_Id)
then
Error_Msg_N
("level of return expression type is deeper than "
@@ -2398,7 +2398,7 @@ package body Sem_Ch6 is
-- means that it is equivalent to Is_Expression_Function_Or_Completion
-- invoked on Spec_Id declared below and not to Is_Expression_Function.
- Acc_Objs : List_Id := No_List;
+ Acc_Decl : Node_Id := Empty;
Desig_View : Entity_Id := Empty;
Exch_Views : Elist_Id := No_Elist;
Prot_Typ : Entity_Id := Empty;
@@ -2464,6 +2464,13 @@ package body Sem_Ch6 is
-- Checks for a function with a no return statements, and also performs
-- the warning checks implemented by Check_Returns.
+ procedure Compute_Extra_Accessibility
+ (Subp_Id : Entity_Id;
+ Extra_Access_Id : Entity_Id);
+ -- Update the value of the Extra_Accessibility_Of_Subprogram object of
+ -- Subp_Id given the value of an Extra_Accessibility formal by taking
+ -- the maximum of the two values.
+
function Disambiguate_Spec return Entity_Id;
-- When a primitive is declared between the private view and the full
-- view of a concurrent type which implements an interface, a special
@@ -2476,13 +2483,6 @@ package body Sem_Ch6 is
-- limited views with the non-limited ones. Return the list of changes
-- to be used to undo the transformation.
- procedure Generate_Minimum_Accessibility
- (Extra_Access : Entity_Id;
- Related_Form : Entity_Id := Empty);
- -- Generate a minimum accessibility object for a given extra
- -- accessibility formal (Extra_Access) and its related formal if it
- -- exists.
-
function Is_Private_Concurrent_Primitive
(Subp_Id : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id is a primitive of a concurrent
@@ -3052,6 +3052,41 @@ package body Sem_Ch6 is
end if;
end Check_Missing_Return;
+ ---------------------------------
+ -- Compute_Extra_Accessibility --
+ ---------------------------------
+
+ procedure Compute_Extra_Accessibility
+ (Subp_Id : Entity_Id;
+ Extra_Access_Id : Entity_Id)
+ is
+ Acc_Id : Entity_Id;
+
+ begin
+ if Present (Extra_Accessibility_Of_Subprogram (Subp_Id)) then
+ Set_Expression (Acc_Decl,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Standard_Natural, Loc),
+ Attribute_Name => Name_Max,
+ Expressions => New_List (
+ New_Occurrence_Of (Extra_Access_Id, Loc),
+ Expression (Acc_Decl))));
+
+ else
+ Acc_Id := Make_Temporary (Loc, 'A', Extra_Access_Id);
+ Acc_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Acc_Id,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression =>
+ New_Occurrence_Of (Extra_Access_Id, Loc));
+
+ Set_Extra_Accessibility_Of_Subprogram (Subp_Id, Acc_Id);
+ end if;
+ end Compute_Extra_Accessibility;
+
-----------------------
-- Disambiguate_Spec --
-----------------------
@@ -3225,60 +3260,6 @@ package body Sem_Ch6 is
return Result;
end Exchange_Limited_Views;
- ------------------------------------
- -- Generate_Minimum_Accessibility --
- ------------------------------------
-
- procedure Generate_Minimum_Accessibility
- (Extra_Access : Entity_Id;
- Related_Form : Entity_Id := Empty)
- is
- Loc : constant Source_Ptr := Sloc (N);
-
- Decl : Node_Id;
- Form : Entity_Id;
-
- begin
- -- When no related formal exists then we are dealing with an
- -- extra accessibility formal for a function result.
-
- if No (Related_Form) then
- Form := Extra_Access;
- else
- Form := Related_Form;
- end if;
-
- -- Declare the minimum accessibility object
-
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'A', Extra_Access),
- Object_Definition => New_Occurrence_Of (Standard_Natural, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Standard_Natural, Loc),
- Attribute_Name => Name_Min,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Scope_Depth (Body_Id)),
- New_Occurrence_Of (Extra_Access, Loc))));
-
- -- Add the new local object to the Minimum_Acc_Obj to be later
- -- prepended to the subprogram's list of declarations after we
- -- are sure all expansion is done.
-
- if Present (Acc_Objs) then
- Prepend (Decl, Acc_Objs);
- else
- Acc_Objs := New_List (Decl);
- end if;
-
- -- Register the object and analyze it
-
- Set_Minimum_Accessibility (Form, Defining_Identifier (Decl));
-
- Analyze (Decl);
- end Generate_Minimum_Accessibility;
-
-------------------------------------
-- Is_Private_Concurrent_Primitive --
-------------------------------------
@@ -4437,69 +4418,60 @@ package body Sem_Ch6 is
end;
end if;
- -- Generate minimum accessibility local objects to correspond with
- -- any extra formal added for anonymous access types. This new local
- -- object can then be used instead of the formal in case it is used
- -- in an actual to a call to a nested subprogram.
-
- -- This method is used to supplement our "small integer model" for
- -- accessibility check generation (for more information see
- -- Accessibility_Level).
-
- -- Because we allow accessibility values greater than our expected value
- -- passing along the same extra accessibility formal as an actual
- -- to a nested subprogram becomes a problem because high values mean
- -- different things to the callee even though they are the same to the
- -- caller. So, as described in the first section, we create a local
- -- object representing the minimum of the accessibility level value that
- -- is passed in and the accessibility level of the callee's parameter
- -- and locals and use it in the case of a call to a nested subprogram.
- -- This generated object is referred to as a "minimum accessibility
- -- level."
-
- -- Loop through formals if the subprogram is capable of accepting
- -- a generated local object. If it is not, then it is also not
- -- capable of having local subprograms meaning it would not need
- -- a minimum accessibility level object anyway.
-
- if Has_Declarations (N) then
+ -- Compute the value of the Extra_Accessibility_Of_Subprogram object if
+ -- there are extra formals added for anonymous access types. This value
+ -- is used as an offset in the computation of the dynamic accessibility
+ -- level of the entities declared in the subprogram.
+
+ -- This method supplements our "small integer" model for the generation
+ -- of dynamic accessibility checks. It ensures that the local objects of
+ -- the subprogram have a deeper dynamic accessibility level than any of
+ -- the nonlocal objects the subprogram may access indirectly.
+
+ if Nkind (N) = N_Subprogram_Body
+ and then not No_Dynamic_Accessibility_Checks_Enabled (N)
+ and then (No (Spec_Id)
+ or else No (Extra_Accessibility_Of_Subprogram (Spec_Id)))
+ then
declare
Subp_Id : constant Entity_Id := Subprogram_Entity;
+ Par_Id : constant Entity_Id := Enclosing_Subprogram (Subp_Id);
Formal : Node_Id;
begin
Formal := First_Formal (Subp_Id);
while Present (Formal) loop
- -- Generate the minimum accessibility level object:
-
- -- Ann : constant natural := natural'min(1, paramL);
-
- if Present (Extra_Accessibility (Formal)) then
- Generate_Minimum_Accessibility
- (Extra_Accessibility (Formal), Formal);
+ if Present (Extra_Accessibility_Of_Object (Formal)) then
+ Compute_Extra_Accessibility
+ (Subp_Id, Extra_Accessibility_Of_Object (Formal));
end if;
Next_Formal (Formal);
end loop;
- -- Generate the minimum accessibility level object for the
- -- function's Extra_Accessibility_Of_Result:
-
- -- Ann : constant natural := natural'min (1, funcL);
-
if Ekind (Subp_Id) = E_Function
and then Present (Extra_Accessibility_Of_Result (Subp_Id))
then
- Generate_Minimum_Accessibility
- (Extra_Accessibility_Of_Result (Subp_Id));
+ Compute_Extra_Accessibility
+ (Subp_Id, Extra_Accessibility_Of_Result (Subp_Id));
+ end if;
+
+ -- For nested subprograms present in the source code, also take
+ -- into account the extra accessibility of the parent; generated
+ -- subprograms are not supposed to perform accessibility checks.
- -- Replace the Extra_Accessibility_Of_Result with the new
- -- minimum accessibility object.
+ if Comes_From_Source (Subp_Id)
+ and then Present (Par_Id)
+ and then Present (Extra_Accessibility_Of_Subprogram (Par_Id))
+ then
+ Compute_Extra_Accessibility
+ (Subp_Id, Extra_Accessibility_Of_Subprogram (Par_Id));
+ end if;
- Set_Extra_Accessibility_Of_Result
- (Subp_Id, Minimum_Accessibility
- (Extra_Accessibility_Of_Result (Subp_Id)));
+ if Present (Acc_Decl) then
+ Prepend_To (Declarations (N), Acc_Decl);
+ Analyze (Acc_Decl);
end if;
end;
end if;
@@ -4645,11 +4617,6 @@ package body Sem_Ch6 is
Inspect_Deferred_Constant_Completion (Declarations (N));
Analyze (Handled_Statement_Sequence (N));
- -- Prepend the declaration of minimum accessibility objects to the list
- -- of declarations after analysis of the statements and contracts.
-
- Prepend_List (Acc_Objs, Declarations (N));
-
-- Deal with end of scope processing for the body
Process_End_Label
@@ -4685,23 +4652,6 @@ package body Sem_Ch6 is
end if;
end if;
- -- Restore the Extra_Accessibility_Of_Result object that was clobbered
- -- earlier, so that the name of the local temporary does not leak.
-
- if Has_Declarations (N) then
- declare
- Subp_Id : constant Entity_Id := Subprogram_Entity;
-
- begin
- if Ekind (Subp_Id) = E_Function
- and then Present (Extra_Accessibility_Of_Result (Subp_Id))
- then
- Set_Extra_Accessibility_Of_Result (Subp_Id,
- Related_Expression (Extra_Accessibility_Of_Result (Subp_Id)));
- end if;
- end;
- end if;
-
-- If we are compiling an entry wrapper, remove the enclosing
-- synchronized object from the stack.
@@ -8902,14 +8852,14 @@ package body Sem_Ch6 is
-- On access-to-subprogram types it is used to determine if the target
-- function might return an object with tasks.
- function Needs_Accessibility_Check_Extra
+ function Needs_Extra_Accessibility
(E : Entity_Id;
Formal : Node_Id) return Boolean;
-- Determines whether the given formal of E needs an extra formal for
-- supporting accessibility checking. Returns True for both anonymous
-- access formals and formals of named access types that are marked as
-- controlling formals. The latter case can occur when the subprogram
- -- Expand_Dispatching_Call creates a subprogram-type and substitutes
+ -- Expand_Dispatching_Call creates a subprogram type and substitutes
-- the types of access-to-class-wide actuals for the anonymous access-
-- to-specific-type of controlling formals.
@@ -9025,13 +8975,43 @@ package body Sem_Ch6 is
(Collect_Ancestors_With_No_Task_Parts (Original));
end Might_Need_BIP_Task_Actuals;
- -------------------------------------
- -- Needs_Accessibility_Check_Extra --
- -------------------------------------
+ -------------------------------
+ -- Needs_Extra_Accessibility --
+ -------------------------------
- function Needs_Accessibility_Check_Extra
+ function Needs_Extra_Accessibility
(E : Entity_Id;
- Formal : Node_Id) return Boolean is
+ Formal : Node_Id) return Boolean
+ is
+ Btyp : constant Entity_Id := Base_Type (Etype (Formal));
+ -- Base_Type is applied to handle cases where there is a null
+ -- exclusion and the formal may have an access subtype.
+
+ function Profile_Needs_Extra (Typ : Entity_Id) return Boolean;
+ -- Return True if the profile of Typ, a subprogram type, needs at
+ -- least one extra formal for supporting accessibility checking.
+
+ -------------------------
+ -- Profile_Needs_Extra --
+ -------------------------
+
+ function Profile_Needs_Extra (Typ : Entity_Id) return Boolean is
+ Formal : Entity_Id;
+
+ begin
+ Formal := First_Formal (Typ);
+ while Present (Formal) loop
+ if Needs_Extra_Accessibility (E, Formal) then
+ return True;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ return False;
+ end Profile_Needs_Extra;
+
+ -- Start of processing for Needs_Extra_Accessibility
begin
-- For dispatching operations this extra formal is not suppressed
@@ -9053,15 +9033,13 @@ package body Sem_Ch6 is
return False;
end if;
- -- Base_Type is applied to handle cases where there is a null
- -- exclusion the formal may have an access subtype.
-
return
- Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type
- or else
- (Is_Controlling_Formal (Formal)
- and then Is_Access_Type (Base_Type (Etype (Formal))));
- end Needs_Accessibility_Check_Extra;
+ Ekind (Btyp) = E_Anonymous_Access_Type
+ or else (Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
+ and then Profile_Needs_Extra (Designated_Type (Btyp)))
+ or else (Is_Access_Type (Btyp)
+ and then Is_Controlling_Formal (Formal));
+ end Needs_Extra_Accessibility;
-----------------------
-- Parent_Subprogram --
@@ -9554,7 +9532,7 @@ package body Sem_Ch6 is
-- Extra formal for supporting accessibility checking
- if Needs_Accessibility_Check_Extra (Ref_E, Formal) then
+ if Needs_Extra_Accessibility (Ref_E, Formal) then
pragma Assert (No (Parent_Formal)
or else Present (Extra_Accessibility (Parent_Formal)));
pragma Assert (No (Alias_Formal)
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index aa4c813115d..ce8fe01f463 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -2388,8 +2388,6 @@ package body Sem_Ch9 is
It : Interp;
Enclosing : Entity_Id;
Target_Obj : Node_Id := Empty;
- Req_Scope : Entity_Id;
- Outer_Ent : Entity_Id;
Synch_Type : Entity_Id := Empty;
-- Start of processing for Analyze_Requeue
@@ -2456,38 +2454,18 @@ package body Sem_Ch9 is
end;
end if;
- -- If an explicit target object is given then we have to check the
- -- restrictions of 9.5.4(6).
+ -- If an explicit target object is specified then we have to check the
+ -- restrictions of 9.5.4(6), unless it is a parameter of the innermost
+ -- enclosing accept statement or entry body.
- if Present (Target_Obj) then
-
- -- Locate containing concurrent unit and determine enclosing entry
- -- body or outermost enclosing accept statement within the unit.
-
- Outer_Ent := Empty;
- for S in reverse 0 .. Scope_Stack.Last loop
- Req_Scope := Scope_Stack.Table (S).Entity;
-
- exit when Is_Concurrent_Type (Req_Scope);
-
- if Is_Entry (Req_Scope) then
- Outer_Ent := Req_Scope;
- end if;
- end loop;
-
- pragma Assert (Present (Outer_Ent));
-
- -- Check that the accessibility level of the target object is not
- -- greater or equal to the outermost enclosing accept statement (or
- -- entry body) unless it is a parameter of the innermost enclosing
- -- accept statement (or entry body).
-
- if Static_Accessibility_Level (Target_Obj, Zero_On_Dynamic_Level)
- >= Scope_Depth (Outer_Ent)
- and then
- (not Is_Entity_Name (Target_Obj)
- or else not Is_Formal (Entity (Target_Obj))
- or else Enclosing /= Scope (Entity (Target_Obj)))
+ if Present (Target_Obj)
+ and then
+ (not Is_Entity_Name (Target_Obj)
+ or else not Is_Formal (Entity (Target_Obj))
+ or else Enclosing /= Scope (Entity (Target_Obj)))
+ then
+ if Static_Accessibility_Level (Target_Obj)
+ > Static_Local_Access_Level (Enclosing)
then
Error_Msg_N
("target object has invalid level for requeue", Target_Obj);
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 61bc36e677c..1aea3db3ba2 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3774,8 +3774,8 @@ package body Sem_Res is
elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type
and then Nkind (Parent (N)) = N_Type_Conversion
and then
- Type_Access_Level (Etype (Parent (N)))
- < Static_Accessibility_Level (A, Zero_On_Dynamic_Level)
+ Static_Type_Access_Level (Etype (Parent (N)))
+ < Static_Accessibility_Level (A)
then
Accessibility_Error ("conversion");
@@ -3783,25 +3783,25 @@ package body Sem_Res is
and then Nkind (Parent (N)) = N_Assignment_Statement
and then
Static_Accessibility_Level
- (Name (Parent (N)), Object_Decl_Level)
- < Static_Accessibility_Level (A, Zero_On_Dynamic_Level)
+ (Name (Parent (N)), Object_Decl_Level => True)
+ < Static_Accessibility_Level (A)
then
Accessibility_Error ("assignment");
elsif Nkind (Parent (N)) = N_Qualified_Expression
and then Nkind (Parent (Parent (N))) = N_Allocator
and then
- Type_Access_Level (Etype (Parent (Parent (N))))
- < Static_Accessibility_Level (A, Zero_On_Dynamic_Level)
+ Static_Type_Access_Level (Etype (Parent (Parent (N))))
+ < Static_Accessibility_Level (A)
then
Accessibility_Error ("allocator");
elsif In_Return_Value (N)
and then Comes_From_Source (N)
and then
- Subprogram_Access_Level (Current_Subprogram)
+ Static_Subprogram_Access_Level (Current_Subprogram)
< Static_Accessibility_Level
- (A, Zero_On_Dynamic_Level, In_Return_Context => True)
+ (A, In_Return_Context => True)
then
Accessibility_Error ("return");
end if;
@@ -5410,8 +5410,8 @@ package body Sem_Res is
return;
end if;
- if Static_Accessibility_Level (Disc_Exp, Zero_On_Dynamic_Level)
- > Deepest_Type_Access_Level (Alloc_Typ)
+ if Static_Accessibility_Level (Disc_Exp)
+ > Static_Type_Access_Level (Alloc_Typ, Deepest => True)
then
Accessibility_Error (Disc_Exp);
end if;
@@ -5653,8 +5653,9 @@ package body Sem_Res is
elsif Has_Anonymous_Access_Discriminant (Subtyp)
and then Is_Entity_Name (Exp)
and then Is_Formal (Entity (Exp))
- and then Static_Accessibility_Level (Exp, Zero_On_Dynamic_Level)
- > Deepest_Type_Access_Level (Typ)
+ and then
+ Static_Accessibility_Level (Exp)
+ > Static_Type_Access_Level (Typ, Deepest => True)
then
Accessibility_Error (Exp);
end if;
@@ -5733,8 +5734,8 @@ package body Sem_Res is
Exp_Typ := Entity (E);
end if;
- if Type_Access_Level (Exp_Typ) >
- Deepest_Type_Access_Level (Typ)
+ if Static_Type_Access_Level (Exp_Typ)
+ > Static_Type_Access_Level (Typ, Deepest => True)
then
if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On;
@@ -8322,11 +8323,14 @@ package body Sem_Res is
end if;
end loop;
+ -- Mark it now since it is going to be rewritten below
+
+ Set_Analyzed (E_Name);
+
New_N :=
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (S, Loc),
- Selector_Name =>
- New_Occurrence_Of (Entity (E_Name), Loc));
+ Prefix => New_Occurrence_Of (S, Loc),
+ Selector_Name => New_Occurrence_Of (Entity (E_Name), Loc));
Rewrite (E_Name, New_N);
Analyze (E_Name);
@@ -13860,8 +13864,8 @@ package body Sem_Res is
and then
Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type)
then
- if Type_Access_Level (Target_Type) <
- Deepest_Type_Access_Level (Opnd_Type)
+ if Static_Type_Access_Level (Opnd_Type)
+ > Static_Type_Access_Level (Target_Type, Deepest => True)
then
if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On;
@@ -14122,8 +14126,9 @@ package body Sem_Res 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)
+ if Static_Type_Access_Level (Opnd_Type)
+ > Static_Type_Access_Level
+ (Target_Type, Deepest => True)
then
Report_Error_N
("operand has deeper level than target", Operand,
@@ -14172,8 +14177,9 @@ package body Sem_Res is
-- statically less deep than that of the target type, else
-- implicit conversion is disallowed (by RM12-8.6(27.1/3)).
- elsif Type_Access_Level (Opnd_Type) >
- Deepest_Type_Access_Level (Target_Type)
+ elsif Static_Type_Access_Level (Opnd_Type)
+ > Static_Type_Access_Level
+ (Target_Type, Deepest => True)
then
Report_Error_N
("implicit conversion of anonymous access value "
@@ -14197,8 +14203,8 @@ package body Sem_Res is
-- master of the call to the enclosing function (RM 3.10.2(10.3),
-- 3.10.2(14) and 3.10.2(10.5)).
- elsif Type_Access_Level (Opnd_Type, Assoc_Ent => Operand)
- > Deepest_Type_Access_Level (Target_Type)
+ elsif Static_Type_Access_Level (Opnd_Type, Assoc_Node => Operand)
+ > Static_Type_Access_Level (Target_Type, Deepest => True)
and then (Nkind (Associated_Node_For_Itype (Opnd_Type))
/= N_Function_Specification
or else Ekind (Target_Type) in Anonymous_Access_Kind
@@ -14249,9 +14255,9 @@ package body Sem_Res is
-- checking the prefix of the operand for this case).
if Nkind (Operand) = N_Selected_Component
- and then Static_Accessibility_Level
- (Operand, Zero_On_Dynamic_Level)
- > Deepest_Type_Access_Level (Target_Type)
+ and then
+ Static_Accessibility_Level (Operand)
+ > Static_Type_Access_Level (Target_Type, Deepest => True)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning.
@@ -14432,8 +14438,8 @@ package body Sem_Res is
-- Check the static accessibility rule of 4.6(20)
- if Type_Access_Level (Opnd_Type) >
- Deepest_Type_Access_Level (Target_Type)
+ if Static_Type_Access_Level (Opnd_Type)
+ > Static_Type_Access_Level (Target_Type, Deepest => True)
then
Report_Error_N
("operand type has deeper accessibility level than target",
diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads
index 1985d86eca3..54902ac9fce 100644
--- a/gcc/ada/sem_res.ads
+++ b/gcc/ada/sem_res.ads
@@ -130,8 +130,7 @@ package Sem_Res is
procedure Resolve_Entry (Entry_Name : Node_Id);
-- Find name of entry being called, and resolve prefix of name with its
- -- own type. For now we assume that the prefix cannot be overloaded and
- -- the name of the entry plays no role in the resolution.
+ -- own type.
procedure Resolve_Implicit_Dereference (P : Node_Id);
-- Called when P is the prefix of an indexed component, or of a selected
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index d8bf6f0608f..b196a6cee7d 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -5076,7 +5076,7 @@ package body Sem_Util is
and then Is_Public_Operation
and then Scope_Depth (Pref_Encl_Typ)
>= Static_Accessibility_Level
- (Context, Object_Decl_Level)
+ (Context, Object_Decl_Level => True)
then
Error_Msg_N
("??possible unprotected access to protected data", Expr);
