------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A C C E S S I B I L I T Y --
-- --
-- B o d y --
-- --
-- Copyright (C) 2022-2023, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Elists; use Elists;
with Errout; use Errout;
with Einfo.Utils; use Einfo.Utils;
with Exp_Atag; use Exp_Atag;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
package body Accessibility is
---------------------------
-- Accessibility_Message --
---------------------------
procedure Accessibility_Message (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Prefix (N);
Indic : Node_Id := Parent (Parent (N));
begin
-- In an instance, this is a runtime check, but one we know will fail,
-- so generate an appropriate warning.
if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_F
("non-local pointer cannot point to local object<<", P);
Error_Msg_F ("\Program_Error [<<", P);
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, Typ);
return;
else
Error_Msg_F ("non-local pointer cannot point to local object", P);
-- Check for case where we have a missing access definition
if Is_Record_Type (Current_Scope)
and then
Nkind (Parent (N)) in N_Discriminant_Association
| N_Index_Or_Discriminant_Constraint
then
Indic := Parent (Parent (N));
while Present (Indic)
and then Nkind (Indic) /= N_Subtype_Indication
loop
Indic := Parent (Indic);
end loop;
if Present (Indic) then
Error_Msg_NE
("\use an access definition for" &
" the access discriminant of&",
N, Entity (Subtype_Mark (Indic)));
end if;
end if;
end if;
end Accessibility_Message;
-------------------------
-- Accessibility_Level --
-------------------------
function Accessibility_Level
(Expr : Node_Id;
Level : Accessibility_Level_Kind;
In_Return_Context : Boolean := False;
Allow_Alt_Model : Boolean := True) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Expr);
function Accessibility_Level (Expr : Node_Id) return Node_Id
is (Accessibility_Level (Expr, Level, In_Return_Context));
-- 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 Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id;
-- Centralized processing of subprogram calls which may appear in prefix
-- notation.
function Typ_Access_Level (Typ : Entity_Id) return Uint
is (Type_Access_Level (Typ, Allow_Alt_Model));
-- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid
-- passing the parameter specifically in every call.
----------------------------------
-- Innermost_Master_Scope_Depth --
----------------------------------
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;
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 scope.
-- The RM 7.6.1(3) definition of "master" includes statements
-- and conditions for loops among other things. Are these cases
-- detected properly ???
while Present (Node_Par) loop
Ent := Defining_Entity_Or_Empty (Node_Par);
if Present (Ent) then
Encl_Scop := Find_Enclosing_Scope (Ent);
-- Ignore transient scopes made during expansion while also
-- taking into account certain expansions - like iterators
-- which get expanded into renamings and thus not marked
-- as coming from source.
if Comes_From_Source (Node_Par)
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. So, instead,
-- continue to move up the parent chain since the scope
-- depth of the type's parent is the same as that of the
-- type.
if not Scope_Depth_Set (Encl_Scop) then
pragma Assert (Nkind (Parent (Encl_Scop))
= N_Full_Type_Declaration);
else
return
Scope_Depth (Encl_Scop) + Master_Lvl_Modifier;
end if;
end if;
-- For a return statement within a function, return
-- the depth of the function itself. This is not just
-- a small optimization, but matters when analyzing
-- the expression in an expression function before
-- the body is created.
elsif Nkind (Node_Par) in N_Extended_Return_Statement
| N_Simple_Return_Statement
then
return Scope_Depth (Enclosing_Subprogram (Node_Par));
-- Statements are counted as masters
elsif Is_Master (Node_Par) then
Master_Lvl_Modifier := Master_Lvl_Modifier + 1;
end if;
Node_Par := Parent (Node_Par);
end loop;
-- Should never reach the following return
pragma Assert (False);
return Scope_Depth (Current_Scope) + 1;
end Innermost_Master_Scope_Depth;
------------------------
-- Make_Level_Literal --
------------------------
function Make_Level_Literal (Level : Uint) return Node_Id is
Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
begin
Set_Etype (Result, Standard_Natural);
return Result;
end Make_Level_Literal;
--------------------------------------
-- Function_Call_Or_Allocator_Level --
--------------------------------------
function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id is
Par : Node_Id;
Prev_Par : Node_Id;
begin
-- Results of functions are objects, so we either get the
-- accessibility of the function or, in case of a call which is
-- indirect, the level of the access-to-subprogram type.
-- This code looks wrong ???
if Nkind (N) = N_Function_Call
and then Ada_Version < Ada_2005
then
if Is_Entity_Name (Name (N)) then
return Make_Level_Literal
(Subprogram_Access_Level (Entity (Name (N))));
else
return Make_Level_Literal
(Typ_Access_Level (Etype (Prefix (Name (N)))));
end if;
-- We ignore coextensions as they cannot be implemented under the
-- "small-integer" model.
elsif Nkind (N) = N_Allocator
and then (Is_Static_Coextension (N)
or else Is_Dynamic_Coextension (N))
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
end if;
-- Named access types have a designated level
if Is_Named_Access_Type (Etype (N)) then
return Make_Level_Literal (Typ_Access_Level (Etype (N)));
-- Otherwise, the level is dictated by RM 3.10.2 (10.7/3)
else
-- Check No_Dynamic_Accessibility_Checks restriction override for
-- alternative accessibility model.
if Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (N)
and then Is_Anonymous_Access_Type (Etype (N))
then
-- In the alternative model the level is that of the
-- designated type.
if Debug_Flag_Underscore_B then
return Make_Level_Literal (Typ_Access_Level (Etype (N)));
-- For function calls the level is that of the innermost
-- master, otherwise (for allocators etc.) we get the level
-- of the corresponding anonymous access type, which is
-- calculated through the normal path of execution.
elsif Nkind (N) = N_Function_Call then
return Make_Level_Literal
(Innermost_Master_Scope_Depth (Expr));
end if;
end if;
if Nkind (N) = N_Function_Call then
-- Dynamic checks are generated when we are within a return
-- value or we are in a function call within an anonymous
-- access discriminant constraint of a return object (signified
-- by In_Return_Context) on the side of the callee.
-- So, in this case, return accessibility level of the
-- enclosing subprogram.
if In_Return_Value (N)
or else In_Return_Context
then
return Make_Level_Literal
(Subprogram_Access_Level (Current_Subprogram));
end if;
end if;
-- When the call is being dereferenced the level is that of the
-- enclosing master of the dereferenced call.
if Nkind (Parent (N)) in N_Explicit_Dereference
| N_Indexed_Component
| N_Selected_Component
then
return Make_Level_Literal
(Innermost_Master_Scope_Depth (Expr));
end if;
-- Find any relevant enclosing parent nodes that designate an
-- object being initialized.
-- Note: The above is only relevant if the result is used "in its
-- entirety" as RM 3.10.2 (10.2/3) states. However, this is
-- accounted for in the case statement in the main body of
-- Accessibility_Level for N_Selected_Component.
Par := Parent (Expr);
Prev_Par := Empty;
while Present (Par) loop
-- Detect an expanded implicit conversion, typically this
-- occurs on implicitly converted actuals in calls.
-- Does this catch all implicit conversions ???
if Nkind (Par) = N_Type_Conversion
and then Is_Named_Access_Type (Etype (Par))
then
return Make_Level_Literal
(Typ_Access_Level (Etype (Par)));
end if;
-- Jump out when we hit an object declaration or the right-hand
-- side of an assignment, or a construct such as an aggregate
-- subtype indication which would be the result is not used
-- "in its entirety."
exit when Nkind (Par) in N_Object_Declaration
or else (Nkind (Par) = N_Assignment_Statement
and then Name (Par) /= Prev_Par);
Prev_Par := Par;
Par := Parent (Par);
end loop;
-- Assignment statements are handled in a similar way in
-- accordance to the left-hand part. However, strictly speaking,
-- this is illegal according to the RM, but this change is needed
-- to pass an ACATS C-test and is useful in general ???
case Nkind (Par) is
when N_Object_Declaration =>
return Make_Level_Literal
(Scope_Depth
(Scope (Defining_Identifier (Par))));
when N_Assignment_Statement =>
-- Return the accessibility level of the left-hand part
return Accessibility_Level
(Expr => Name (Par),
Level => Object_Decl_Level,
In_Return_Context => In_Return_Context);
when others =>
return Make_Level_Literal
(Innermost_Master_Scope_Depth (Expr));
end case;
end if;
end Function_Call_Or_Allocator_Level;
-- Local variables
E : Node_Id := Original_Node (Expr);
Pre : Node_Id;
-- Start of processing for Accessibility_Level
begin
-- 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.
if Present (Param_Entity (Expr)) then
E := Param_Entity (Expr);
end if;
-- Extract the entity
if Nkind (E) in N_Has_Entity and then Present (Entity (E)) then
E := Entity (E);
-- Deal with a possible renaming of a private protected component
if Ekind (E) in E_Constant | E_Variable and then Is_Prival (E) then
E := Prival_Link (E);
end if;
end if;
-- Perform the processing on the expression
case Nkind (E) is
-- 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));
-- The accessibility level is that of the access type, except for an
-- anonymous allocators which have special rules defined in RM 3.10.2
-- (14/3).
when N_Allocator =>
return Function_Call_Or_Allocator_Level (E);
-- We could reach this point for two reasons. Either the expression
-- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or
-- we are looking at the access attributes directly ('Access,
-- 'Address, or 'Unchecked_Access).
when N_Attribute_Reference =>
Pre := Original_Node (Prefix (E));
-- Regular 'Access attribute presence means we have to look at the
-- prefix.
if Attribute_Name (E) = Name_Access then
return Accessibility_Level (Prefix (E));
-- Unchecked or unrestricted attributes have unlimited depth
elsif Attribute_Name (E) in Name_Address
| Name_Unchecked_Access
| Name_Unrestricted_Access
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
-- 'Access can be taken further against other special attributes,
-- so handle these cases explicitly.
elsif Attribute_Name (E)
in Name_Old | Name_Loop_Entry | Name_Result
then
-- Named access types
if Is_Named_Access_Type (Etype (Pre)) then
return Make_Level_Literal
(Typ_Access_Level (Etype (Pre)));
-- Anonymous access types
elsif Nkind (Pre) in N_Has_Entity
and then Ekind (Entity (Pre)) not in Subprogram_Kind
and then Present (Get_Dynamic_Accessibility (Entity (Pre)))
and then Level = Dynamic_Level
then
return New_Occurrence_Of
(Get_Dynamic_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
-- an implicit constant declaration - in turn defining the
-- accessibility level to be that of the implicit constant
-- declaration.
else
return Make_Level_Literal
(Innermost_Master_Scope_Depth (Expr));
end if;
else
raise Program_Error;
end if;
-- This is the "base case" for accessibility level calculations which
-- means we are near the end of our recursive traversal.
when N_Defining_Identifier =>
-- A dynamic check is performed on the side of the callee when we
-- are within a return statement, so return a library-level
-- accessibility level to null out checks on the side of the
-- caller.
if Is_Explicitly_Aliased (E)
and then (In_Return_Context
or else (Level /= Dynamic_Level
and then In_Return_Value (Expr)))
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
-- Something went wrong and an extra accessibility formal has not
-- been generated when one should have ???
elsif Is_Formal (E)
and then No (Get_Dynamic_Accessibility (E))
and then Ekind (Etype (E)) = E_Anonymous_Access_Type
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
-- Stand-alone object of an anonymous access type "SAOAAT"
elsif (Is_Formal (E)
or else Ekind (E) in E_Variable
| E_Constant)
and then Present (Get_Dynamic_Accessibility (E))
and then (Level = Dynamic_Level
or else Level = Zero_On_Dynamic_Level)
then
if Level = Zero_On_Dynamic_Level then
return Make_Level_Literal
(Scope_Depth (Standard_Standard));
end if;
-- No_Dynamic_Accessibility_Checks restriction override for
-- alternative accessibility model.
if Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (E)
then
-- In the alternative model the level 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)));
else
return Make_Level_Literal
(Scope_Depth (Enclosing_Dynamic_Scope (E)));
end if;
end if;
-- Return the dynamic level in the normal case
return New_Occurrence_Of
(Get_Dynamic_Accessibility (E), Loc);
-- Initialization procedures have a special extra accessibility
-- parameter associated with the level at which the object
-- being initialized exists
elsif 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);
-- Current instance of the type is deeper than that of the type
-- according to RM 3.10.2 (21).
elsif Is_Type (E) then
-- When restriction No_Dynamic_Accessibility_Checks is active
-- along with -gnatd_b.
if Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (E)
and then Debug_Flag_Underscore_B
then
return Make_Level_Literal (Typ_Access_Level (E));
end if;
-- Normal path
return Make_Level_Literal (Typ_Access_Level (E) + 1);
-- Move up the renamed entity or object if it came from source
-- since expansion may have created a dummy renaming under
-- certain circumstances.
-- Note: We check if the original node of the renaming comes
-- from source because the node may have been rewritten.
elsif Present (Renamed_Entity_Or_Object (E))
and then Comes_From_Source
(Original_Node (Renamed_Entity_Or_Object (E)))
then
return Accessibility_Level (Renamed_Entity_Or_Object (E));
-- Named access types get their level from their associated type
elsif Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
(Typ_Access_Level (Etype (E)));
-- Check if E is an expansion-generated renaming of an iterator
-- by examining Related_Expression. If so, determine the
-- accessibility level based on the original expression.
elsif Ekind (E) in E_Constant | E_Variable
and then Present (Related_Expression (E))
then
return Accessibility_Level (Related_Expression (E));
elsif Level = Dynamic_Level
and then Ekind (E) in E_In_Parameter | E_In_Out_Parameter
and then Present (Init_Proc_Level_Formal (Scope (E)))
then
return New_Occurrence_Of
(Init_Proc_Level_Formal (Scope (E)), Loc);
-- Normal object - get the level of the enclosing scope
else
return Make_Level_Literal
(Scope_Depth (Enclosing_Dynamic_Scope (E)));
end if;
-- Handle indexed and selected components including the special cases
-- whereby there is an implicit dereference, a component of a
-- composite type, or a function call in prefix notation.
-- We don't handle function calls in prefix notation correctly ???
when N_Indexed_Component | N_Selected_Component | N_Slice =>
Pre := Prefix (E);
-- Fetch the original node when the prefix comes from the result
-- of expanding a function call since we want to find the level
-- of the original source call.
if not Comes_From_Source (Pre)
and then Nkind (Original_Node (Pre)) = N_Function_Call
then
Pre := Original_Node (Pre);
end if;
-- When E is an indexed component or selected component and
-- the current Expr is a function call, we know that we are
-- looking at an expanded call in prefix notation.
if Nkind (Expr) = N_Function_Call then
return Function_Call_Or_Allocator_Level (Expr);
-- If the prefix is a named access type, then we are dealing
-- with an implicit deferences. In that case the level is that
-- 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)));
-- 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)));
-- A nondiscriminant selected component where the component
-- is an anonymous access type means that its associated
-- level is that of the containing type - see RM 3.10.2 (16).
-- Note that when restriction No_Dynamic_Accessibility_Checks is
-- in effect we treat discriminant components as regular
-- components.
elsif
(Nkind (E) = N_Selected_Component
and then Ekind (Etype (E)) = E_Anonymous_Access_Type
and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type
and then (not (Nkind (Selector_Name (E)) in N_Has_Entity
and then Ekind (Entity (Selector_Name (E)))
= E_Discriminant)
-- The alternative accessibility models both treat
-- discriminants as regular components.
or else (No_Dynamic_Accessibility_Checks_Enabled (E)
and then Allow_Alt_Model)))
-- Arrays featuring components of anonymous access components
-- get their corresponding level from their containing type's
-- declaration.
or else
(Nkind (E) = N_Indexed_Component
and then Ekind (Etype (E)) = E_Anonymous_Access_Type
and then Ekind (Etype (Pre)) in Array_Kind
and then Ekind (Component_Type (Base_Type (Etype (Pre))))
= E_Anonymous_Access_Type)
then
-- When restriction No_Dynamic_Accessibility_Checks is active
-- and -gnatd_b set, the level is that of the designated type.
if Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (E)
and then Debug_Flag_Underscore_B
then
return Make_Level_Literal
(Typ_Access_Level (Etype (E)));
end if;
-- Otherwise proceed normally
return Make_Level_Literal
(Typ_Access_Level (Etype (Prefix (E))));
-- The accessibility calculation routine that handles function
-- calls (Function_Call_Level) assumes, in the case the
-- result is of an anonymous access type, that the result will be
-- used "in its entirety" when the call is present within an
-- assignment or object declaration.
-- To properly handle cases where the result is not used in its
-- entirety, we test if the prefix of the component in question is
-- a function call, which tells us that one of its components has
-- been identified and is being accessed. Therefore we can
-- conclude that the result is not used "in its entirety"
-- according to RM 3.10.2 (10.2/3).
elsif Nkind (Pre) = N_Function_Call
and then not Is_Named_Access_Type (Etype (Pre))
then
-- Dynamic checks are generated when we are within a return
-- value or we are in a function call within an anonymous
-- access discriminant constraint of a return object (signified
-- by In_Return_Context) on the side of the callee.
-- So, in this case, return a library accessibility level to
-- null out the check on the side of the caller.
if (In_Return_Value (E)
or else In_Return_Context)
and then Level /= Dynamic_Level
then
return Make_Level_Literal
(Scope_Depth (Standard_Standard));
end if;
return Make_Level_Literal
(Innermost_Master_Scope_Depth (Expr));
-- Otherwise, continue recursing over the expression prefixes
else
return Accessibility_Level (Prefix (E));
end if;
-- Qualified expressions
when N_Qualified_Expression =>
if Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
(Typ_Access_Level (Etype (E)));
else
return Accessibility_Level (Expression (E));
end if;
-- Handle function calls
when N_Function_Call =>
return Function_Call_Or_Allocator_Level (E);
-- Explicit dereference accessibility level calculation
when N_Explicit_Dereference =>
Pre := Original_Node (Prefix (E));
-- The prefix is a named access type so the level is taken from
-- its type.
if Is_Named_Access_Type (Etype (Pre)) then
return Make_Level_Literal (Typ_Access_Level (Etype (Pre)));
-- Otherwise, recurse deeper
else
return Accessibility_Level (Prefix (E));
end if;
-- Type conversions
when N_Type_Conversion | N_Unchecked_Type_Conversion =>
-- View conversions are special in that they require use to
-- inspect the expression of the type conversion.
-- Allocators of anonymous access types are internally generated,
-- so recurse deeper in that case as well.
if Is_View_Conversion (E)
or else Ekind (Etype (E)) = E_Anonymous_Access_Type
then
return Accessibility_Level (Expression (E));
-- We don't care about the master if we are looking at a named
-- access type.
elsif Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
(Typ_Access_Level (Etype (E)));
-- In section RM 3.10.2 (10/4) the accessibility rules for
-- aggregates and value conversions are outlined. Are these
-- followed in the case of initialization of an object ???
-- Should use Innermost_Master_Scope_Depth ???
else
return Accessibility_Level (Current_Scope);
end if;
-- Default to the type accessibility level for the type of the
-- expression's entity.
when others =>
return Make_Level_Literal (Typ_Access_Level (Etype (E)));
end case;
end Accessibility_Level;
-------------------------------
-- Apply_Accessibility_Check --
-------------------------------
procedure Apply_Accessibility_Check
(N : Node_Id;
Typ : Entity_Id;
Insert_Node : Node_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Check_Cond : Node_Id;
Param_Ent : Entity_Id := Param_Entity (N);
Param_Level : Node_Id;
Type_Level : Node_Id;
begin
-- Verify we haven't tried to add a dynamic accessibility check when we
-- shouldn't.
pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N));
if Ada_Version >= Ada_2012
and then No (Param_Ent)
and then Is_Entity_Name (N)
and then Ekind (Entity (N)) in E_Constant | E_Variable
and then Present (Effective_Extra_Accessibility (Entity (N)))
then
Param_Ent := Entity (N);
while Present (Renamed_Object (Param_Ent)) loop
-- Renamed_Object must return an Entity_Name here
-- because of preceding "Present (E_E_A (...))" test.
Param_Ent := Entity (Renamed_Object (Param_Ent));
end loop;
end if;
if Inside_A_Generic then
return;
-- Only apply the run-time check if the access parameter has an
-- associated extra access level parameter and when accessibility checks
-- are enabled.
elsif Present (Param_Ent)
and then Present (Get_Dynamic_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);
-- Use the dynamic accessibility parameter for the function's result
-- when one has been created instead of statically referring to the
-- deepest type level so as to appropriatly handle the rules for
-- RM 3.10.2 (10.1/3).
if Ekind (Scope (Param_Ent)) = E_Function
and then In_Return_Value (N)
and then Ekind (Typ) = E_Anonymous_Access_Type
then
-- Associate the level of the result type to the extra result
-- accessibility parameter belonging to the current function.
if Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then
Type_Level :=
New_Occurrence_Of
(Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc);
-- In Ada 2005 and earlier modes, a result extra accessibility
-- parameter is not generated and no dynamic check is performed.
else
return;
end if;
-- Otherwise get the type's accessibility level normally
else
Type_Level :=
Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
end if;
-- Raise Program_Error if the accessibility level of the access
-- parameter is deeper than the level of the target access type.
Check_Cond :=
Make_Op_Gt (Loc,
Left_Opnd => Param_Level,
Right_Opnd => Type_Level);
Insert_Action (Insert_Node,
Make_Raise_Program_Error (Loc,
Condition => Check_Cond,
Reason => PE_Accessibility_Check_Failed));
Analyze_And_Resolve (N);
-- If constant folding has happened on the condition for the
-- generated error, then warn about it being unconditional.
if Nkind (Check_Cond) = N_Identifier
and then Entity (Check_Cond) = Standard_True
then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_N ("accessibility check fails<<", N);
Error_Msg_N ("\Program_Error [<<", N);
end if;
end if;
end Apply_Accessibility_Check;
---------------------------------------------
-- Apply_Accessibility_Check_For_Allocator --
---------------------------------------------
procedure Apply_Accessibility_Check_For_Allocator
(N : Node_Id;
Exp : Node_Id;
Ref : Node_Id;
Built_In_Place : Boolean := False)
is
Loc : constant Source_Ptr := Sloc (N);
PtrT : constant Entity_Id := Etype (N);
DesigT : constant Entity_Id := Designated_Type (PtrT);
Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
Cond : Node_Id;
Fin_Call : Node_Id;
Free_Stmt : Node_Id;
Obj_Ref : Node_Id;
Stmts : List_Id;
begin
if Ada_Version >= Ada_2005
and then Is_Class_Wide_Type (DesigT)
and then Tagged_Type_Expansion
and then not Scope_Suppress.Suppress (Accessibility_Check)
and then not No_Dynamic_Accessibility_Checks_Enabled (Ref)
and then
(Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
or else
(Is_Class_Wide_Type (Etype (Exp))
and then Scope (PtrT) /= Current_Scope))
then
-- If the allocator was built in place, Ref is already a reference
-- to the access object initialized to the result of the allocator
-- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
-- Remove_Side_Effects for cases where the build-in-place call may
-- still be the prefix of the reference (to avoid generating
-- duplicate calls). Otherwise, it is the entity associated with
-- the object containing the address of the allocated object.
if Built_In_Place then
Remove_Side_Effects (Ref);
Obj_Ref := New_Copy_Tree (Ref);
else
Obj_Ref := New_Occurrence_Of (Ref, Loc);
end if;
-- For access to interface types we must generate code to displace
-- the pointer to the base of the object since the subsequent code
-- references components located in the TSD of the object (which
-- is associated with the primary dispatch table --see a-tags.ads)
-- and also generates code invoking Free, which requires also a
-- reference to the base of the unallocated object.
if Is_Interface (DesigT) and then Tagged_Type_Expansion then
Obj_Ref :=
Unchecked_Convert_To (Etype (Obj_Ref),
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Base_Address), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address),
New_Copy_Tree (Obj_Ref)))));
end if;
-- Step 1: Create the object clean up code
Stmts := New_List;
-- Deallocate the object if the accessibility check fails. This is
-- done only on targets or profiles that support deallocation.
-- Free (Obj_Ref);
if RTE_Available (RE_Free) then
Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref));
Set_Storage_Pool (Free_Stmt, Pool_Id);
Append_To (Stmts, Free_Stmt);
-- The target or profile cannot deallocate objects
else
Free_Stmt := Empty;
end if;
-- Finalize the object if applicable. Generate:
-- [Deep_]Finalize (Obj_Ref.all);
if Needs_Finalization (DesigT)
and then not No_Heap_Finalization (PtrT)
then
Fin_Call :=
Make_Final_Call
(Obj_Ref =>
Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
Typ => DesigT);
-- Guard against a missing [Deep_]Finalize when the designated
-- type was not properly frozen.
if No (Fin_Call) then
Fin_Call := Make_Null_Statement (Loc);
end if;
-- When the target or profile supports deallocation, wrap the
-- finalization call in a block to ensure proper deallocation even
-- if finalization fails. Generate:
-- begin
-- <Fin_Call>
-- exception
-- when others =>
-- <Free_Stmt>
-- raise;
-- end;
if Present (Free_Stmt) then
Fin_Call :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Fin_Call),
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
New_Copy_Tree (Free_Stmt),
Make_Raise_Statement (Loc))))));
end if;
Prepend_To (Stmts, Fin_Call);
end if;
-- Signal the accessibility failure through a Program_Error
Append_To (Stmts,
Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed));
-- Step 2: Create the accessibility comparison
-- Generate:
-- Ref'Tag
Obj_Ref :=
Make_Attribute_Reference (Loc,
Prefix => Obj_Ref,
Attribute_Name => Name_Tag);
-- For tagged types, determine the accessibility level by looking at
-- the type specific data of the dispatch table. Generate:
-- Type_Specific_Data (Address (Ref'Tag)).Access_Level
if Tagged_Type_Expansion then
Cond := Build_Get_Access_Level (Loc, Obj_Ref);
-- Use a runtime call to determine the accessibility level when
-- compiling on virtual machine targets. Generate:
-- Get_Access_Level (Ref'Tag)
else
Cond :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc),
Parameter_Associations => New_List (Obj_Ref));
end if;
Cond :=
Make_Op_Gt (Loc,
Left_Opnd => Cond,
Right_Opnd => Accessibility_Level (N, Dynamic_Level));
-- Due to the complexity and side effects of the check, utilize an if
-- statement instead of the regular Program_Error circuitry.
Insert_Action (N,
Make_Implicit_If_Statement (N,
Condition => Cond,
Then_Statements => Stmts));
end if;
end Apply_Accessibility_Check_For_Allocator;
------------------------------------------
-- Check_Return_Construct_Accessibility --
------------------------------------------
procedure Check_Return_Construct_Accessibility
(Return_Stmt : Node_Id;
Stm_Entity : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Return_Stmt);
Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity);
R_Type : constant Entity_Id := Etype (Scope_Id);
-- Function result subtype
function First_Selector (Assoc : Node_Id) return Node_Id;
-- Obtain the first selector or choice from a given association
function Is_Formal_Of_Current_Function
(Assoc_Expr : Entity_Id) return Boolean;
-- Predicate to test if a given expression associated with a
-- discriminant is a formal parameter to the function in which the
-- return construct we checking applies to.
--------------------
-- First_Selector --
--------------------
function First_Selector (Assoc : Node_Id) return Node_Id is
begin
if Nkind (Assoc) = N_Component_Association then
return First (Choices (Assoc));
elsif Nkind (Assoc) = N_Discriminant_Association then
return (First (Selector_Names (Assoc)));
else
raise Program_Error;
end if;
end First_Selector;
-----------------------------------
-- Is_Formal_Of_Current_Function --
-----------------------------------
function Is_Formal_Of_Current_Function
(Assoc_Expr : Entity_Id) return Boolean is
begin
return Is_Entity_Name (Assoc_Expr)
and then Enclosing_Subprogram
(Entity (Assoc_Expr)) = Scope_Id
and then Is_Formal (Entity (Assoc_Expr));
end Is_Formal_Of_Current_Function;
-- Local declarations
Assoc : Node_Id := Empty;
-- Assoc should perhaps be renamed and declared as a
-- Node_Or_Entity_Id since it encompasses not only component and
-- discriminant associations, but also discriminant components within
-- a type declaration or subtype indication ???
Assoc_Expr : Node_Id;
Assoc_Present : Boolean := False;
Check_Cond : Node_Id;
Unseen_Disc_Count : Nat := 0;
Seen_Discs : Elist_Id;
Disc : Entity_Id;
First_Disc : Entity_Id;
Obj_Decl : Node_Id;
Return_Con : Node_Id;
Unqual : Node_Id;
-- Start of processing for Check_Return_Construct_Accessibility
begin
-- Only perform checks on record types with access discriminants and
-- non-internally generated functions.
if not Is_Record_Type (R_Type)
or else not Has_Anonymous_Access_Discriminant (R_Type)
or else not Comes_From_Source (Return_Stmt)
then
return;
end if;
-- We are only interested in return statements
if Nkind (Return_Stmt) not in
N_Extended_Return_Statement | N_Simple_Return_Statement
then
return;
end if;
-- Fetch the object from the return statement, in the case of a
-- simple return statement the expression is part of the node.
if Nkind (Return_Stmt) = N_Extended_Return_Statement then
-- Obtain the object definition from the expanded extended return
Return_Con := First (Return_Object_Declarations (Return_Stmt));
while Present (Return_Con) loop
-- Inspect the original node to avoid object declarations
-- expanded into renamings.
if Nkind (Original_Node (Return_Con)) = N_Object_Declaration
and then Comes_From_Source (Original_Node (Return_Con))
then
exit;
end if;
Nlists.Next (Return_Con);
end loop;
pragma Assert (Present (Return_Con));
-- Could be dealing with a renaming
Return_Con := Original_Node (Return_Con);
else
Return_Con := Expression (Return_Stmt);
end if;
-- Obtain the accessibility levels of the expressions associated
-- with all anonymous access discriminants, then generate a
-- dynamic check or static error when relevant.
-- Note the repeated use of Original_Node to avoid checking
-- expanded code.
Unqual := Original_Node (Unqualify (Original_Node (Return_Con)));
-- Get the corresponding declaration based on the return object's
-- identifier.
if Nkind (Unqual) = N_Identifier
and then Nkind (Parent (Entity (Unqual)))
in N_Object_Declaration
| N_Object_Renaming_Declaration
then
Obj_Decl := Original_Node (Parent (Entity (Unqual)));
-- We were passed the object declaration directly, so use it
elsif Nkind (Unqual) in N_Object_Declaration
| N_Object_Renaming_Declaration
then
Obj_Decl := Unqual;
-- Otherwise, we are looking at something else
else
Obj_Decl := Empty;
end if;
-- Hop up object renamings when present
if Present (Obj_Decl)
and then Nkind (Obj_Decl) = N_Object_Renaming_Declaration
then
while Nkind (Obj_Decl) = N_Object_Renaming_Declaration loop
if Nkind (Name (Obj_Decl)) not in N_Entity then
-- We may be looking at the expansion of iterators or
-- some other internally generated construct, so it is safe
-- to ignore checks ???
if not Comes_From_Source (Obj_Decl) then
return;
end if;
Obj_Decl := Original_Node
(Declaration_Node
(Ultimate_Prefix (Name (Obj_Decl))));
-- Move up to the next declaration based on the object's name
else
Obj_Decl := Original_Node
(Declaration_Node (Name (Obj_Decl)));
end if;
end loop;
end if;
-- Obtain the discriminant values from the return aggregate
-- Do we cover extension aggregates correctly ???
if Nkind (Unqual) = N_Aggregate then
if Present (Expressions (Unqual)) then
Assoc := First (Expressions (Unqual));
else
Assoc := First (Component_Associations (Unqual));
end if;
-- There is an object declaration for the return object
elsif Present (Obj_Decl) then
-- When a subtype indication is present in an object declaration
-- it must contain the object's discriminants.
if Nkind (Object_Definition (Obj_Decl)) = N_Subtype_Indication then
Assoc := First
(Constraints
(Constraint
(Object_Definition (Obj_Decl))));
-- The object declaration contains an aggregate
elsif Present (Expression (Obj_Decl)) then
if Nkind (Unqualify (Expression (Obj_Decl))) = N_Aggregate then
-- Grab the first associated discriminant expresion
if Present
(Expressions (Unqualify (Expression (Obj_Decl))))
then
Assoc := First
(Expressions
(Unqualify (Expression (Obj_Decl))));
else
Assoc := First
(Component_Associations
(Unqualify (Expression (Obj_Decl))));
end if;
-- Otherwise, this is something else
else
return;
end if;
-- There are no supplied discriminants in the object declaration,
-- so get them from the type definition since they must be default
-- initialized.
-- Do we handle constrained subtypes correctly ???
elsif Nkind (Unqual) = N_Object_Declaration then
Assoc := First_Discriminant
(Etype (Object_Definition (Obj_Decl)));
else
Assoc := First_Discriminant (Etype (Unqual));
end if;
-- When we are not looking at an aggregate or an identifier, return
-- since any other construct (like a function call) is not
-- applicable since checks will be performed on the side of the
-- callee.
else
return;
end if;
-- Obtain the discriminants so we know the actual type in case the
-- value of their associated expression gets implicitly converted.
if No (Obj_Decl) then
pragma Assert (Nkind (Unqual) = N_Aggregate);
Disc := First_Discriminant (Etype (Unqual));
else
Disc := First_Discriminant
(Etype (Defining_Identifier (Obj_Decl)));
end if;
-- Preserve the first discriminant for checking named associations
First_Disc := Disc;
-- Count the number of discriminants for processing an aggregate
-- which includes an others.
Disc := First_Disc;
while Present (Disc) loop
Unseen_Disc_Count := Unseen_Disc_Count + 1;
Next_Discriminant (Disc);
end loop;
Seen_Discs := New_Elmt_List;
-- Loop through each of the discriminants and check each expression
-- associated with an anonymous access discriminant.
-- When named associations occur in the return aggregate then
-- discriminants can be in any order, so we need to ensure we do
-- not continue to loop when all discriminants have been seen.
Disc := First_Disc;
while Present (Assoc)
and then (Present (Disc) or else Assoc_Present)
and then Unseen_Disc_Count > 0
loop
-- Handle named associations by searching through the names of
-- the relevant discriminant components.
if Nkind (Assoc)
in N_Component_Association | N_Discriminant_Association
then
Assoc_Expr := Expression (Assoc);
Assoc_Present := True;
-- We currently don't handle box initialized discriminants,
-- however, since default initialized anonymous access
-- discriminants are a corner case, this is ok for now ???
if Nkind (Assoc) = N_Component_Association
and then Box_Present (Assoc)
then
if Nkind (First_Selector (Assoc)) = N_Others_Choice then
Unseen_Disc_Count := 0;
end if;
-- When others is present we must identify a discriminant we
-- haven't already seen so as to get the appropriate type for
-- the static accessibility check.
-- This works because all components within an others clause
-- must have the same type.
elsif Nkind (First_Selector (Assoc)) = N_Others_Choice then
Disc := First_Disc;
Outer : while Present (Disc) loop
declare
Current_Seen_Disc : Elmt_Id;
begin
-- Move through the list of identified discriminants
Current_Seen_Disc := First_Elmt (Seen_Discs);
while Present (Current_Seen_Disc) loop
-- Exit the loop when we found a match
exit when
Chars (Node (Current_Seen_Disc)) = Chars (Disc);
Next_Elmt (Current_Seen_Disc);
end loop;
-- When we have exited the above loop without finding
-- a match then we know that Disc has not been seen.
exit Outer when No (Current_Seen_Disc);
end;
Next_Discriminant (Disc);
end loop Outer;
-- If we got to an others clause with a non-zero
-- discriminant count there must be a discriminant left to
-- check.
pragma Assert (Present (Disc));
-- Set the unseen discriminant count to zero because we know
-- an others clause sets all remaining components of an
-- aggregate.
Unseen_Disc_Count := 0;
-- Move through each of the selectors in the named association
-- and obtain a discriminant for accessibility checking if one
-- is referenced in the list. Also track which discriminants
-- are referenced for the purpose of handling an others clause.
else
declare
Assoc_Choice : Node_Id;
Curr_Disc : Node_Id;
begin
Disc := Empty;
Curr_Disc := First_Disc;
while Present (Curr_Disc) loop
-- Check each of the choices in the associations for a
-- match to the name of the current discriminant.
Assoc_Choice := First_Selector (Assoc);
while Present (Assoc_Choice) loop
-- When the name matches we track that we have seen
-- the discriminant, but instead of exiting the
-- loop we continue iterating to make sure all the
-- discriminants within the named association get
-- tracked.
if Chars (Assoc_Choice) = Chars (Curr_Disc) then
Append_Elmt (Curr_Disc, Seen_Discs);
Disc := Curr_Disc;
Unseen_Disc_Count := Unseen_Disc_Count - 1;
end if;
Next (Assoc_Choice);
end loop;
Next_Discriminant (Curr_Disc);
end loop;
end;
end if;
-- Unwrap the associated expression if we are looking at a default
-- initialized type declaration. In this case Assoc is not really
-- an association, but a component declaration. Should Assoc be
-- renamed in some way to be more clear ???
-- This occurs when the return object does not initialize
-- discriminant and instead relies on the type declaration for
-- their supplied values.
elsif Nkind (Assoc) in N_Entity
and then Ekind (Assoc) = E_Discriminant
then
Append_Elmt (Disc, Seen_Discs);
Assoc_Expr := Discriminant_Default_Value (Assoc);
Unseen_Disc_Count := Unseen_Disc_Count - 1;
-- Otherwise, there is nothing to do because Assoc is an
-- expression within the return aggregate itself.
else
Append_Elmt (Disc, Seen_Discs);
Assoc_Expr := Assoc;
Unseen_Disc_Count := Unseen_Disc_Count - 1;
end if;
-- Check the accessibility level of the expression when the
-- discriminant is of an anonymous access type.
if Present (Assoc_Expr)
and then Present (Disc)
and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type
-- We disable the check when we have a tagged return type and
-- the associated expression for the discriminant is a formal
-- parameter since the check would require us to compare the
-- accessibility level of Assoc_Expr to the level of the
-- Extra_Accessibility_Of_Result of the function - which is
-- currently disabled for functions with tagged return types.
-- This may change in the future ???
-- See Needs_Result_Accessibility_Level for details.
and then not
(No (Extra_Accessibility_Of_Result (Scope_Id))
and then Is_Formal_Of_Current_Function (Assoc_Expr)
and then Is_Tagged_Type (Etype (Scope_Id)))
then
-- Generate a dynamic check based on the extra accessibility of
-- the result or the scope of the current function.
Check_Cond :=
Make_Op_Gt (Loc,
Left_Opnd => Accessibility_Level
(Expr => Assoc_Expr,
Level => Dynamic_Level,
In_Return_Context => True),
Right_Opnd =>
(if Present (Extra_Accessibility_Of_Result (Scope_Id))
-- When Assoc_Expr is a formal we have to look at the
-- extra accessibility-level formal associated with
-- the result.
and then Is_Formal_Of_Current_Function (Assoc_Expr)
then
New_Occurrence_Of
(Extra_Accessibility_Of_Result (Scope_Id), Loc)
-- Otherwise, we compare the level of Assoc_Expr to the
-- scope of the current function.
else
Make_Integer_Literal
(Loc, Scope_Depth (Scope (Scope_Id)))));
Insert_Before_And_Analyze (Return_Stmt,
Make_Raise_Program_Error (Loc,
Condition => Check_Cond,
Reason => PE_Accessibility_Check_Failed));
-- If constant folding has happened on the condition for the
-- generated error, then warn about it being unconditional when
-- we know an error will be raised.
if Nkind (Check_Cond) = N_Identifier
and then Entity (Check_Cond) = Standard_True
then
Error_Msg_N
("access discriminant in return object would be a dangling"
& " reference", Return_Stmt);
end if;
end if;
-- Iterate over the discriminants, except when we have encountered
-- a named association since the discriminant order becomes
-- irrelevant in that case.
if not Assoc_Present then
Next_Discriminant (Disc);
end if;
-- Iterate over associations
if not Is_List_Member (Assoc) then
exit;
else
Nlists.Next (Assoc);
end if;
end loop;
end Check_Return_Construct_Accessibility;
-------------------------------
-- Deepest_Type_Access_Level --
-------------------------------
function Deepest_Type_Access_Level
(Typ : Entity_Id;
Allow_Alt_Model : Boolean := True) return Uint
is
begin
if Ekind (Typ) = E_Anonymous_Access_Type
and then not Is_Local_Anonymous_Access (Typ)
and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
then
-- No_Dynamic_Accessibility_Checks override for alternative
-- accessibility model.
if Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (Typ)
then
return Type_Access_Level (Typ, Allow_Alt_Model);
end if;
-- Typ is the type of an Ada 2012 stand-alone object of an anonymous
-- access type.
return
Scope_Depth (Enclosing_Dynamic_Scope
(Defining_Identifier
(Associated_Node_For_Itype (Typ))));
-- For generic formal type, return Int'Last (infinite).
-- See comment preceding Is_Generic_Type call in Type_Access_Level.
elsif Is_Generic_Type (Root_Type (Typ)) then
return UI_From_Int (Int'Last);
else
return Type_Access_Level (Typ, Allow_Alt_Model);
end if;
end Deepest_Type_Access_Level;
-----------------------------------
-- Effective_Extra_Accessibility --
-----------------------------------
function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
begin
if Present (Renamed_Object (Id))
and then Is_Entity_Name (Renamed_Object (Id))
then
return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
else
return Extra_Accessibility (Id);
end if;
end Effective_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 --
-----------------------
function Has_Access_Values (T : Entity_Id) return Boolean
is
Typ : constant Entity_Id := Underlying_Type (T);
begin
-- Case of a private type which is not completed yet. This can only
-- happen in the case of a generic formal type appearing directly, or
-- as a component of the type to which this function is being applied
-- at the top level. Return False in this case, since we certainly do
-- not know that the type contains access types.
if No (Typ) then
return False;
elsif Is_Access_Type (Typ) then
return True;
elsif Is_Array_Type (Typ) then
return Has_Access_Values (Component_Type (Typ));
elsif Is_Record_Type (Typ) then
declare
Comp : Entity_Id;
begin
-- Loop to check components
Comp := First_Component_Or_Discriminant (Typ);
while Present (Comp) loop
-- Check for access component, tag field does not count, even
-- though it is implemented internally using an access type.
if Has_Access_Values (Etype (Comp))
and then Chars (Comp) /= Name_uTag
then
return True;
end if;
Next_Component_Or_Discriminant (Comp);
end loop;
end;
return False;
else
return False;
end if;
end Has_Access_Values;
---------------------------------------
-- Has_Anonymous_Access_Discriminant --
---------------------------------------
function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean
is
Disc : Node_Id;
begin
if not Has_Discriminants (Typ) then
return False;
end if;
Disc := First_Discriminant (Typ);
while Present (Disc) loop
if Ekind (Etype (Disc)) = E_Anonymous_Access_Type then
return True;
end if;
Next_Discriminant (Disc);
end loop;
return False;
end Has_Anonymous_Access_Discriminant;
--------------------------------------------
-- Has_Unconstrained_Access_Discriminants --
--------------------------------------------
function Has_Unconstrained_Access_Discriminants
(Subtyp : Entity_Id) return Boolean
is
Discr : Entity_Id;
begin
if Has_Discriminants (Subtyp)
and then not Is_Constrained (Subtyp)
then
Discr := First_Discriminant (Subtyp);
while Present (Discr) loop
if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
return True;
end if;
Next_Discriminant (Discr);
end loop;
end if;
return False;
end Has_Unconstrained_Access_Discriminants;
--------------------------------
-- Is_Anonymous_Access_Actual --
--------------------------------
function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean is
Par : Node_Id;
begin
if Ekind (Etype (N)) /= E_Anonymous_Access_Type then
return False;
end if;
Par := Parent (N);
while Present (Par)
and then Nkind (Par) in N_Case_Expression
| N_If_Expression
| N_Parameter_Association
loop
Par := Parent (Par);
end loop;
return Nkind (Par) in N_Subprogram_Call;
end Is_Anonymous_Access_Actual;
--------------------------------------
-- Is_Special_Aliased_Formal_Access --
--------------------------------------
function Is_Special_Aliased_Formal_Access
(Exp : Node_Id;
In_Return_Context : Boolean := False) return Boolean
is
Scop : constant Entity_Id := Current_Subprogram;
begin
-- Verify the expression is an access reference to 'Access within a
-- return statement as this is the only time an explicitly aliased
-- formal has different semantics.
if Nkind (Exp) /= N_Attribute_Reference
or else Get_Attribute_Id (Attribute_Name (Exp)) /= Attribute_Access
or else not (In_Return_Value (Exp)
or else In_Return_Context)
or else not Needs_Result_Accessibility_Level (Scop)
then
return False;
end if;
-- Check if the prefix of the reference is indeed an explicitly aliased
-- formal parameter for the function Scop. Additionally, we must check
-- that Scop returns an anonymous access type, otherwise the special
-- rules dictating a need for a dynamic check are not in effect.
return Is_Entity_Name (Prefix (Exp))
and then Is_Explicitly_Aliased (Entity (Prefix (Exp)));
end Is_Special_Aliased_Formal_Access;
--------------------------------------
-- Needs_Result_Accessibility_Level --
--------------------------------------
function Needs_Result_Accessibility_Level
(Func_Id : Entity_Id) return Boolean
is
Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
function Has_Unconstrained_Access_Discriminant_Component
(Comp_Typ : Entity_Id) return Boolean;
-- Returns True if any component of the type has an unconstrained access
-- discriminant.
-----------------------------------------------------
-- Has_Unconstrained_Access_Discriminant_Component --
-----------------------------------------------------
function Has_Unconstrained_Access_Discriminant_Component
(Comp_Typ : Entity_Id) return Boolean
is
begin
if not Is_Limited_Type (Comp_Typ) then
return False;
-- Only limited types can have access discriminants with
-- defaults.
elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then
return True;
elsif Is_Array_Type (Comp_Typ) then
return Has_Unconstrained_Access_Discriminant_Component
(Underlying_Type (Component_Type (Comp_Typ)));
elsif Is_Record_Type (Comp_Typ) then
declare
Comp : Entity_Id;
begin
Comp := First_Component (Comp_Typ);
while Present (Comp) loop
if Has_Unconstrained_Access_Discriminant_Component
(Underlying_Type (Etype (Comp)))
then
return True;
end if;
Next_Component (Comp);
end loop;
end;
end if;
return False;
end Has_Unconstrained_Access_Discriminant_Component;
Disable_Tagged_Cases : constant Boolean := True;
-- Flag used to temporarily disable a "True" result for tagged types.
-- See comments further below for details.
-- Start of processing for Needs_Result_Accessibility_Level
begin
-- False if completion unavailable, which can happen when we are
-- analyzing an abstract subprogram or if the subprogram has
-- delayed freezing.
if No (Func_Typ) then
return False;
-- False if not a function, also handle enum-lit renames case
elsif Func_Typ = Standard_Void_Type
or else Is_Scalar_Type (Func_Typ)
then
return False;
-- Handle a corner case, a cross-dialect subp renaming. For example,
-- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
-- an Ada 2005 (or earlier) unit references predefined run-time units.
elsif Present (Alias (Func_Id)) then
-- Unimplemented: a cross-dialect subp renaming which does not set
-- the Alias attribute (e.g., a rename of a dereference of an access
-- to subprogram value). ???
return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));
-- Remaining cases require Ada 2012 mode, unless they are dispatching
-- operations, since they may be overridden by Ada_2012 primitives.
elsif Ada_Version < Ada_2012
and then not Is_Dispatching_Operation (Func_Id)
then
return False;
-- Handle the situation where a result is an anonymous access type
-- RM 3.10.2 (10.3/3).
elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then
return True;
-- In the case of, say, a null tagged record result type, the need for
-- this extra parameter might not be obvious so this function returns
-- True for all tagged types for compatibility reasons.
-- A function with, say, a tagged null controlling result type might
-- be overridden by a primitive of an extension having an access
-- discriminant and the overrider and overridden must have compatible
-- calling conventions (including implicitly declared parameters).
-- Similarly, values of one access-to-subprogram type might designate
-- both a primitive subprogram of a given type and a function which is,
-- for example, not a primitive subprogram of any type. Again, this
-- requires calling convention compatibility. It might be possible to
-- solve these issues by introducing wrappers, but that is not the
-- approach that was chosen.
-- Note: Despite the reasoning noted above, the extra accessibility
-- parameter for tagged types is disabled for performance reasons.
elsif Is_Tagged_Type (Func_Typ) then
return not Disable_Tagged_Cases;
elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
return True;
elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
return True;
-- False for all other cases
else
return False;
end if;
end Needs_Result_Accessibility_Level;
------------------------------------------
-- Prefix_With_Safe_Accessibility_Level --
------------------------------------------
function Prefix_With_Safe_Accessibility_Level
(N : Node_Id;
Typ : Entity_Id) return Boolean
is
P : constant Node_Id := Prefix (N);
Aname : constant Name_Id := Attribute_Name (N);
Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
Btyp : constant Entity_Id := Base_Type (Typ);
function Safe_Value_Conversions return Boolean;
-- Return False if the prefix has a value conversion of an array type
----------------------------
-- Safe_Value_Conversions --
----------------------------
function Safe_Value_Conversions return Boolean is
PP : Node_Id := P;
begin
loop
if Nkind (PP) in N_Selected_Component | N_Indexed_Component then
PP := Prefix (PP);
elsif Comes_From_Source (PP)
and then Nkind (PP) in N_Type_Conversion
| N_Unchecked_Type_Conversion
and then Is_Array_Type (Etype (PP))
then
return False;
elsif Comes_From_Source (PP)
and then Nkind (PP) = N_Qualified_Expression
and then Is_Array_Type (Etype (PP))
and then Nkind (Original_Node (Expression (PP))) in
N_Aggregate | N_Extension_Aggregate
then
return False;
else
exit;
end if;
end loop;
return True;
end Safe_Value_Conversions;
-- Start of processing for Prefix_With_Safe_Accessibility_Level
begin
-- No check required for unchecked and unrestricted access
if Attr_Id = Attribute_Unchecked_Access
or else Attr_Id = Attribute_Unrestricted_Access
then
return True;
-- Check value conversions
elsif Ekind (Btyp) = E_General_Access_Type
and then not Safe_Value_Conversions
then
return False;
end if;
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;
In_Return_Context : Boolean := False) return Uint
is
begin
return Intval
(Accessibility_Level (Expr, Level, In_Return_Context));
end Static_Accessibility_Level;
-----------------------
-- Type_Access_Level --
-----------------------
function Type_Access_Level
(Typ : Entity_Id;
Allow_Alt_Model : Boolean := True;
Assoc_Ent : Entity_Id := Empty) return Uint
is
Btyp : Entity_Id := Base_Type (Typ);
Def_Ent : Entity_Id;
begin
-- 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
-- associated with components the level is the same as that of the
-- enclosing composite type. However, special treatment is needed for
-- 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
if Ekind (Btyp) = E_Anonymous_Access_Type then
-- No_Dynamic_Accessibility_Checks restriction override for
-- alternative accessibility model.
if Allow_Alt_Model
and then No_Dynamic_Accessibility_Checks_Enabled (Btyp)
then
-- In the -gnatd_b model, the level of an anonymous access
-- type is always that of the designated type.
if Debug_Flag_Underscore_B then
return Type_Access_Level
(Designated_Type (Btyp), Allow_Alt_Model);
end if;
-- When an anonymous access type's Assoc_Ent 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);
end if;
-- Otherwise take the context of the anonymous access type into
-- account.
-- Obtain the defining entity for the internally generated
-- anonymous access type.
Def_Ent := Defining_Entity_Or_Empty
(Associated_Node_For_Itype (Typ));
if Present (Def_Ent) then
-- When the 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.
-- Since we are only interested in the formal case, avoid
-- the anonymous access result type.
if Is_Subprogram (Def_Ent)
and then not (Ekind (Def_Ent) = E_Function
and then Etype (Def_Ent) = Typ)
then
-- When the type comes from an anonymous access
-- parameter, the level is that of the subprogram
-- declaration.
return Scope_Depth (Def_Ent);
-- When the type is an access discriminant, the level is
-- that of the type.
elsif Ekind (Def_Ent) = E_Discriminant then
return Scope_Depth (Scope (Def_Ent));
end if;
end if;
-- If the type is a nonlocal anonymous access type (such as for
-- an access parameter) we treat it as being declared at the
-- library level to ensure that names such as X.all'access don't
-- fail static accessibility checks.
elsif not Is_Local_Anonymous_Access (Typ) then
return Scope_Depth (Standard_Standard);
-- If this is a return object, the accessibility level is that of
-- the result subtype of the enclosing function. The test here is
-- little complicated, because we have to account for extended
-- return statements that have been rewritten as blocks, in which
-- case we have to find and the Is_Return_Object attribute of the
-- itype's associated object. It would be nice to find a way to
-- simplify this test, but it doesn't seem worthwhile to add a new
-- flag just for purposes of this test. ???
elsif Ekind (Scope (Btyp)) = E_Return_Statement
or else
(Is_Itype (Btyp)
and then Nkind (Associated_Node_For_Itype (Btyp)) =
N_Object_Declaration
and then Is_Return_Object
(Defining_Identifier
(Associated_Node_For_Itype (Btyp))))
then
declare
Scop : Entity_Id;
begin
Scop := Scope (Scope (Btyp));
while Present (Scop) loop
exit when Ekind (Scop) = E_Function;
Scop := Scope (Scop);
end loop;
-- Treat the return object's type as having the level of the
-- function's result subtype (as per RM05-6.5(5.3/2)).
return Type_Access_Level (Etype (Scop), Allow_Alt_Model);
end;
end if;
end if;
Btyp := Root_Type (Btyp);
-- The accessibility level of anonymous access types associated with
-- discriminants is that of the current instance of the type, and
-- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
-- AI-402: access discriminants have accessibility based on the
-- object rather than the type in Ada 2005, so the above paragraph
-- doesn't apply.
-- ??? Needs completion with rules from AI-416
if Ada_Version <= Ada_95
and then Ekind (Typ) = E_Anonymous_Access_Type
and then Present (Associated_Node_For_Itype (Typ))
and then Nkind (Associated_Node_For_Itype (Typ)) =
N_Discriminant_Specification
then
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 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
-- 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).
if Is_Generic_Type (Root_Type (Btyp)) then
return Scope_Depth (Standard_Standard);
end if;
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
end Type_Access_Level;
end Accessibility;