new file mode 100644
@@ -0,0 +1,2305 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A C C E S S I B I L I T Y --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2022-2022, 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;
new file mode 100644
@@ -0,0 +1,222 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A C C E S S I B I L I T Y --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2022-2022, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Accessibility level and check generation routines
+
+with Types; use Types;
+with Uintp; use Uintp;
+
+package Accessibility is
+
+ procedure Accessibility_Message (N : Node_Id; Typ : Entity_Id);
+ -- 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);
+ -- Accessibility_Level_Kind is an enumerated type which captures the
+ -- different modes in which an accessibility level could be obtained for
+ -- a given expression.
+
+ -- When in the context of the function Accessibility_Level,
+ -- Accessibility_Level_Kind signals what type of accessibility level to
+ -- obtain. For example, when Level is Dynamic_Level, a defining identifier
+ -- associated with a SAOOAAT may be returned or an N_Integer_Literal node.
+ -- When the level is Object_Decl_Level, an N_Integer_Literal node is
+ -- returned containing the level of the declaration of the object if
+ -- relevant (be it a SAOOAAT or otherwise). Finally, Zero_On_Dynamic_Level
+ -- returns library level for all cases where the accessibility level is
+ -- dynamic (used to bypass static accessibility checks in dynamic cases).
+
+ 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
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Insert_Node : Node_Id);
+ -- Given a name N denoting an access parameter, emits a run-time
+ -- accessibility check (if necessary), checking that the level of
+ -- the object denoted by the access parameter is not deeper than the
+ -- level of the type Typ. Program_Error is raised if the check fails.
+ -- Insert_Node indicates the node where the check should be inserted.
+
+ procedure Apply_Accessibility_Check_For_Allocator
+ (N : Node_Id;
+ Exp : Node_Id;
+ Ref : Node_Id;
+ Built_In_Place : Boolean := False);
+ -- Ada 2005 (AI-344): For an allocator with a class-wide designated
+ -- type, generate an accessibility check to verify that the level of the
+ -- type of the created object is not deeper than the level of the access
+ -- type. If the type of the qualified expression is class-wide, then
+ -- always generate the check (except in the case where it is known to be
+ -- unnecessary, see comment below). Otherwise, only generate the check
+ -- if the level of the qualified expression type is statically deeper
+ -- than the access type.
+ --
+ -- Although the static accessibility will generally have been performed
+ -- as a legality check, it won't have been done in cases where the
+ -- allocator appears in generic body, so a run-time check is needed in
+ -- general. One special case is when the access type is declared in the
+ -- same scope as the class-wide allocator, in which case the check can
+ -- never fail, so it need not be generated.
+ --
+ -- As an open issue, there seem to be cases where the static level
+ -- associated with the class-wide object's underlying type is not
+ -- sufficient to perform the proper accessibility check, such as for
+ -- allocators in nested subprograms or accept statements initialized by
+ -- class-wide formals when the actual originates outside at a deeper
+ -- static level. The nested subprogram case might require passing
+ -- accessibility levels along with class-wide parameters, and the task
+ -- case seems to be an actual gap in the language rules that needs to
+ -- be fixed by the ARG. ???
+
+ procedure Check_Return_Construct_Accessibility
+ (Return_Stmt : Node_Id;
+ Stm_Entity : Entity_Id);
+ -- Apply legality rule of 6.5 (5.9) to the access discriminants of an
+ -- aggregate in a return statement.
+
+ function Deepest_Type_Access_Level
+ (Typ : Entity_Id;
+ Allow_Alt_Model : Boolean := True) return Uint;
+ -- Same as Type_Access_Level, except that if the type is the type of an Ada
+ -- 2012 stand-alone object of an anonymous access type, then return the
+ -- static accessibility level of the object. In that case, the dynamic
+ -- 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).
+
+ -- The Allow_Alt_Model parameter allows the alternative level calculation
+ -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
+ function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id;
+ -- Same as Einfo.Extra_Accessibility except thtat object renames
+ -- are looked through.
+
+ 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
+ -- conservative predicate, if it is not known whether or not T contains
+ -- access values (happens for generic formals in some cases), then False is
+ -- returned. Note that tagged types return False. Even though the tag is
+ -- implemented as an access type internally, this function tests only for
+ -- access types known to the programmer. See also Has_Tagged_Component.
+
+ function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean;
+ -- Returns True if Typ has one or more anonymous access discriminants
+
+ function Prefix_With_Safe_Accessibility_Level
+ (N : Node_Id;
+ Typ : Entity_Id) return Boolean;
+ -- Return True if the prefix does not have a value conversion of an
+ -- array because a value conversion is like an aggregate with respect
+ -- to determining accessibility level (RM 3.10.2); even if evaluation
+ -- 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;
+ 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 Has_Unconstrained_Access_Discriminants
+ (Subtyp : Entity_Id) return Boolean;
+ -- Returns True if the given subtype is unconstrained and has one or more
+ -- access discriminants.
+
+ function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean;
+ -- Determine if N is used as an actual for a call whose corresponding
+ -- formal is of an anonymous access type.
+
+ function Is_Special_Aliased_Formal_Access
+ (Exp : Node_Id;
+ In_Return_Context : Boolean := False) return Boolean;
+ -- Determines whether a dynamic check must be generated for explicitly
+ -- aliased formals within a function Scop for the expression Exp.
+
+ -- In_Return_Context forces Is_Special_Aliased_Formal_Access to assume
+ -- that Exp is within a return value which is useful for checking
+ -- expressions within discriminant associations of return objects.
+
+ -- More specially, Is_Special_Aliased_Formal_Access checks that Exp is a
+ -- 'Access attribute reference within a return statement where the ultimate
+ -- prefix is an aliased formal of Scop and that Scop returns an anonymous
+ -- access type. See RM 3.10.2 for more details.
+
+ function Needs_Result_Accessibility_Level
+ (Func_Id : Entity_Id) return Boolean;
+ -- Ada 2012 (AI05-0234): Return True if the function needs an implicit
+ -- parameter to identify the accessibility level of the function result
+ -- "determined by the point of call".
+
+ function Subprogram_Access_Level (Subp : Entity_Id) return Uint;
+ -- Return the accessibility level of the view denoted by Subp
+
+ function Type_Access_Level
+ (Typ : Entity_Id;
+ Allow_Alt_Model : Boolean := True;
+ Assoc_Ent : Entity_Id := Empty) return Uint;
+ -- Return the accessibility level of Typ
+
+ -- The Allow_Alt_Model parameter allows the alternative level calculation
+ -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
+ -- 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.
+
+end Accessibility;
@@ -570,119 +570,6 @@ package body Checks is
Install_Null_Excluding_Check (P);
end Apply_Access_Check;
- -------------------------------
- -- 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_Address_Clause_Check --
--------------------------------
@@ -189,16 +189,6 @@ package Checks is
-- Determines whether an expression node requires a run-time access
-- check and if so inserts the appropriate run-time check.
- procedure Apply_Accessibility_Check
- (N : Node_Id;
- Typ : Entity_Id;
- Insert_Node : Node_Id);
- -- Given a name N denoting an access parameter, emits a run-time
- -- accessibility check (if necessary), checking that the level of
- -- the object denoted by the access parameter is not deeper than the
- -- level of the type Typ. Program_Error is raised if the check fails.
- -- Insert_Node indicates the node where the check should be inserted.
-
procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id);
-- E is the entity for an object which has an address clause. If checks
-- are enabled, then this procedure generates a check that the specified
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@@ -2215,13 +2216,25 @@ package body Exp_Attr is
-- Local declarations
- Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
+ Enc_Object : Node_Id := Enclosing_Object (Ref_Object);
-- Start of processing for Access_Cases
begin
Btyp_DDT := Designated_Type (Btyp);
+ -- When Enc_Object is a view conversion then RM 3.10.2 (9)
+ -- applies and we obtain the expression being converted.
+ -- Otherwise we do not dig any deeper since a conversion
+ -- might generate a copy and we can't assume it will be as
+ -- long-lived as the original.
+
+ while Nkind (Enc_Object) = N_Type_Conversion
+ and then Is_View_Conversion (Enc_Object)
+ loop
+ Enc_Object := Expression (Enc_Object);
+ end loop;
+
-- Handle designated types that come from the limited view
if From_Limited_With (Btyp_DDT)
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@@ -33,7 +34,6 @@ with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
-with Exp_Atag; use Exp_Atag;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
@@ -560,219 +560,6 @@ package body Exp_Ch4 is
PtrT : constant Entity_Id := Etype (N);
DesigT : constant Entity_Id := Designated_Type (PtrT);
- procedure Apply_Accessibility_Check
- (Ref : Node_Id;
- Built_In_Place : Boolean := False);
- -- Ada 2005 (AI-344): For an allocator with a class-wide designated
- -- type, generate an accessibility check to verify that the level of the
- -- type of the created object is not deeper than the level of the access
- -- type. If the type of the qualified expression is class-wide, then
- -- always generate the check (except in the case where it is known to be
- -- unnecessary, see comment below). Otherwise, only generate the check
- -- if the level of the qualified expression type is statically deeper
- -- than the access type.
- --
- -- Although the static accessibility will generally have been performed
- -- as a legality check, it won't have been done in cases where the
- -- allocator appears in generic body, so a run-time check is needed in
- -- general. One special case is when the access type is declared in the
- -- same scope as the class-wide allocator, in which case the check can
- -- never fail, so it need not be generated.
- --
- -- As an open issue, there seem to be cases where the static level
- -- associated with the class-wide object's underlying type is not
- -- sufficient to perform the proper accessibility check, such as for
- -- allocators in nested subprograms or accept statements initialized by
- -- class-wide formals when the actual originates outside at a deeper
- -- static level. The nested subprogram case might require passing
- -- accessibility levels along with class-wide parameters, and the task
- -- case seems to be an actual gap in the language rules that needs to
- -- be fixed by the ARG. ???
-
- -------------------------------
- -- Apply_Accessibility_Check --
- -------------------------------
-
- procedure Apply_Accessibility_Check
- (Ref : Node_Id;
- Built_In_Place : Boolean := False)
- is
- 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;
-
-- Local variables
Indic : constant Node_Id := Subtype_Mark (Expression (N));
@@ -884,7 +671,8 @@ package body Exp_Ch4 is
if Is_Build_In_Place_Function_Call (Exp) then
Make_Build_In_Place_Call_In_Allocator (N, Exp);
- Apply_Accessibility_Check (N, Built_In_Place => True);
+ Apply_Accessibility_Check_For_Allocator
+ (N, Exp, N, Built_In_Place => True);
return;
-- Ada 2005 (AI-318-02): Specialization of the previous case for
@@ -896,7 +684,8 @@ package body Exp_Ch4 is
elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then
Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp);
- Apply_Accessibility_Check (N, Built_In_Place => True);
+ Apply_Accessibility_Check_For_Allocator
+ (N, Exp, N, Built_In_Place => True);
return;
end if;
@@ -1191,7 +980,7 @@ package body Exp_Ch4 is
-- Note: the accessibility check must be inserted after the call to
-- [Deep_]Adjust to ensure proper completion of the assignment.
- Apply_Accessibility_Check (Temp);
+ Apply_Accessibility_Check_For_Allocator (N, Exp, Temp);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Atree; use Atree;
with Aspects; use Aspects;
with Checks; use Checks;
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Atree; use Atree;
with Aspects; use Aspects;
with Checks; use Checks;
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -399,6 +399,7 @@ GNAT_ADA_OBJS = \
ada/sem_ch12.o \
ada/sem_ch13.o \
ada/sem_ch2.o \
+ ada/accessibility.o \
ada/sem_ch3.o \
ada/sem_ch4.o \
ada/sem_ch5.o \
@@ -98,6 +98,7 @@ package Gen_IL.Fields is
Cleanup_Actions,
Comes_From_Check_Or_Contract,
Comes_From_Extended_Return_Statement,
+ Comes_From_Iterator,
Compile_Time_Known_Aggregate,
Component_Associations,
Component_Clauses,
@@ -906,6 +906,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Subtype_Mark, Node_Id, Default_Empty),
Sy (Access_Definition, Node_Id, Default_Empty),
Sy (Name, Node_Id, Default_Empty),
+ Sm (Comes_From_Iterator, Flag),
Sm (Corresponding_Generic_Association, Node_Id)));
Cc (N_Package_Renaming_Declaration, N_Renaming_Declaration,
@@ -3242,7 +3242,7 @@ package body Sem_Aggr is
end loop;
end;
- else
+ elsif Present (Assign_Indexed_Subp) then
-- Indexed Aggregate. Positional or indexed component
-- can be present, but not both. Choices must be static
-- values or ranges with static bounds.
@@ -25,6 +25,7 @@
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
@@ -10936,72 +10937,12 @@ package body Sem_Attr is
It : Interp;
Nom_Subt : Entity_Id;
- procedure Accessibility_Message;
- -- Error, or warning within an instance, if the static accessibility
- -- rules of 3.10.2 are violated.
-
function Declared_Within_Generic_Unit
(Entity : Entity_Id;
Generic_Unit : Node_Id) return Boolean;
-- Returns True if Declared_Entity is declared within the declarative
-- region of Generic_Unit; otherwise returns False.
- function Prefix_With_Safe_Accessibility_Level return Boolean;
- -- Return True if the prefix does not have a value conversion of an
- -- array because a value conversion is like an aggregate with respect
- -- to determining accessibility level (RM 3.10.2); even if evaluation
- -- of a value conversion is guaranteed to not create a new object,
- -- accessibility rules are defined as if it might.
-
- ---------------------------
- -- Accessibility_Message --
- ---------------------------
-
- procedure Accessibility_Message is
- 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;
-
----------------------------------
-- Declared_Within_Generic_Unit --
----------------------------------
@@ -11029,70 +10970,6 @@ package body Sem_Attr is
return False;
end Declared_Within_Generic_Unit;
- ------------------------------------------
- -- Prefix_With_Safe_Accessibility_Level --
- ------------------------------------------
-
- function Prefix_With_Safe_Accessibility_Level return Boolean is
- 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;
-
-- Start of processing for Resolve_Attribute
begin
@@ -11778,7 +11655,7 @@ package body Sem_Attr is
Intval (Accessibility_Level (P, Dynamic_Level))
> Deepest_Type_Access_Level (Btyp)
then
- Accessibility_Message;
+ Accessibility_Message (N, Typ);
return;
end if;
end;
@@ -11804,7 +11681,7 @@ package body Sem_Attr is
and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
and then Attr_Id /= Attribute_Unrestricted_Access
then
- Accessibility_Message;
+ Accessibility_Message (N, Typ);
return;
-- AI05-0225: If the context is not an access to protected
@@ -11963,8 +11840,8 @@ package body Sem_Attr is
-- array type since a value conversion is like an aggregate with
-- respect to determining accessibility level (RM 3.10.2).
- if not Prefix_With_Safe_Accessibility_Level then
- Accessibility_Message;
+ if not Prefix_With_Safe_Accessibility_Level (N, Typ) then
+ Accessibility_Message (N, Typ);
return;
end if;
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
@@ -2523,6 +2523,7 @@ package body Sem_Ch5 is
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Name =>
New_Copy_Tree (Iter_Name, New_Sloc => Loc));
+ Set_Comes_From_Iterator (Decl);
Insert_Actions (Parent (Parent (N)), New_List (Decl));
Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@@ -745,10 +746,6 @@ package body Sem_Ch6 is
-- Ada 2022: Check that the return expression in a No_Return function
-- meets the conditions specified by RM 6.5.1(5.1/5).
- procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id);
- -- Apply legality rule of 6.5 (5.9) to the access discriminants of an
- -- aggregate in a return statement.
-
procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
-- Check that the return_subtype_indication properly matches the result
-- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
@@ -781,516 +778,6 @@ package body Sem_Ch6 is
Return_Expr);
end Check_No_Return_Expression;
- ------------------------------------------
- -- Check_Return_Construct_Accessibility --
- ------------------------------------------
-
- procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is
-
- 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;
-
-------------------------------------
-- Check_Return_Subtype_Indication --
-------------------------------------
@@ -1495,7 +982,7 @@ package body Sem_Ch6 is
Resolve (Expr, R_Type);
Check_Limited_Return (N, Expr, R_Type);
- Check_Return_Construct_Accessibility (N);
+ Check_Return_Construct_Accessibility (N, Stm_Entity);
-- Ada 2022 (AI12-0269): Any return statement that applies to a
-- nonreturning function shall be a simple_return_statement with
@@ -1551,7 +1038,7 @@ package body Sem_Ch6 is
Check_References (Stm_Entity);
- Check_Return_Construct_Accessibility (N);
+ Check_Return_Construct_Accessibility (N, Stm_Entity);
-- Check RM 6.5 (5.9/3)
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
@@ -30,7 +31,6 @@ with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Erroutc; use Erroutc;
-with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch11; use Exp_Ch11;
with Exp_Util; use Exp_Util;
@@ -255,740 +255,6 @@ package body Sem_Util is
return Interface_List (Nod);
end Abstract_Interface_List;
- -------------------------
- -- 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 rules that define what a master are defined in
- -- RM 7.6.1 (3), and include statements and conditions for loops
- -- among other things. These cases are 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
-
- if Comes_From_Source (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;
-
- --------------------------------
- -- 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;
-
----------------------------------
-- Acquire_Warning_Match_String --
----------------------------------
@@ -7420,57 +6686,16 @@ package body Sem_Util is
else
return Enclosing_Subprogram (Scop);
end if;
- end Current_Subprogram;
-
- ------------------------------
- -- CW_Or_Needs_Finalization --
- ------------------------------
-
- function CW_Or_Needs_Finalization (Typ : Entity_Id) return Boolean is
- begin
- return Is_Class_Wide_Type (Typ) or else Needs_Finalization (Typ);
- end CW_Or_Needs_Finalization;
-
- -------------------------------
- -- 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.
+ end Current_Subprogram;
- elsif Is_Generic_Type (Root_Type (Typ)) then
- return UI_From_Int (Int'Last);
+ ------------------------------
+ -- CW_Or_Needs_Finalization --
+ ------------------------------
- else
- return Type_Access_Level (Typ, Allow_Alt_Model);
- end if;
- end Deepest_Type_Access_Level;
+ function CW_Or_Needs_Finalization (Typ : Entity_Id) return Boolean is
+ begin
+ return Is_Class_Wide_Type (Typ) or else Needs_Finalization (Typ);
+ end CW_Or_Needs_Finalization;
---------------------
-- Defining_Entity --
@@ -8182,21 +7407,6 @@ package body Sem_Util is
return False;
end Discriminated_Size;
- -----------------------------------
- -- 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;
-
-----------------------------
-- Effective_Reads_Enabled --
-----------------------------
@@ -10776,30 +9986,6 @@ package body Sem_Util is
end if;
end Gather_Components;
- -------------------------------
- -- 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;
-
------------------------
-- Get_Actual_Subtype --
------------------------
@@ -12006,85 +11192,6 @@ package body Sem_Util is
end if;
end Get_Views;
- -----------------------
- -- 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_Compatible_Alignment --
------------------------------
@@ -14382,32 +13489,6 @@ package body Sem_Util is
end if;
end Has_Tagged_Component;
- --------------------------------------------
- -- 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;
-
-----------------------------
-- Has_Undefined_Reference --
-----------------------------
@@ -15989,28 +15070,6 @@ package body Sem_Util is
end if;
end Invalid_Scalar_Value;
- --------------------------------
- -- 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_Access_Variable --
------------------------
@@ -21224,38 +20283,6 @@ package body Sem_Util is
and then Is_Single_Concurrent_Type (Etype (Id));
end Is_Single_Task_Object;
- --------------------------------------
- -- 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;
-
-----------------------------
-- Is_Specific_Tagged_Type --
-----------------------------
@@ -23228,144 +22255,6 @@ package body Sem_Util is
end if;
end Needs_One_Actual;
- --------------------------------------
- -- 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;
-
----------------------------
-- Needs_Secondary_Stack --
----------------------------
@@ -29179,19 +28068,6 @@ package body Sem_Util is
and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
end Subject_To_Loop_Entry_Attributes;
- -----------------------------
- -- 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;
-
---------------------
-- Subprogram_Name --
---------------------
@@ -29651,179 +28527,6 @@ package body Sem_Util is
Discard := Traverse (Node);
end Traverse_More_Proc;
- -----------------------
- -- 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;
-
------------------------------------
-- Type_Without_Stream_Operation --
------------------------------------
@@ -44,40 +44,6 @@ package Sem_Util is
-- including the cases where there can't be any because e.g. the type is
-- not tagged.
- type Accessibility_Level_Kind is
- (Dynamic_Level,
- Object_Decl_Level,
- Zero_On_Dynamic_Level);
- -- Accessibility_Level_Kind is an enumerated type which captures the
- -- different modes in which an accessibility level could be obtained for
- -- a given expression.
-
- -- When in the context of the function Accessibility_Level,
- -- Accessibility_Level_Kind signals what type of accessibility level to
- -- obtain. For example, when Level is Dynamic_Level, a defining identifier
- -- associated with a SAOOAAT may be returned or an N_Integer_Literal node.
- -- When the level is Object_Decl_Level, an N_Integer_Literal node is
- -- returned containing the level of the declaration of the object if
- -- relevant (be it a SAOOAAT or otherwise). Finally, Zero_On_Dynamic_Level
- -- returns library level for all cases where the accessibility level is
- -- dynamic (used to bypass static accessibility checks in dynamic cases).
-
- 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.
-
function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String;
-- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to get
-- the given string argument, adding leading and trailing asterisks if they
@@ -696,22 +662,6 @@ package Sem_Util is
-- as Needs_Finalization except with pragma Restrictions (No_Finalization),
-- in which case we know that class-wide objects do not need finalization.
- function Deepest_Type_Access_Level
- (Typ : Entity_Id;
- Allow_Alt_Model : Boolean := True) return Uint;
-
- -- Same as Type_Access_Level, except that if the type is the type of an Ada
- -- 2012 stand-alone object of an anonymous access type, then return the
- -- static accessibility level of the object. In that case, the dynamic
- -- 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).
-
- -- The Allow_Alt_Model parameter allows the alternative level calculation
- -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
-
function Defining_Entity (N : Node_Id) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- declaration has a specification, the entity is obtained from the
@@ -786,10 +736,6 @@ package Sem_Util is
-- private components of protected objects, but is generally useful when
-- restriction No_Implicit_Heap_Allocation is active.
- function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id;
- -- Same as Einfo.Extra_Accessibility except thtat object renames
- -- are looked through.
-
function Effective_Reads_Enabled (Id : Entity_Id) return Boolean;
-- Id should be the entity of a state abstraction, an object, or a type.
-- Returns True iff Id is subject to external property Effective_Reads.
@@ -1146,10 +1092,6 @@ package Sem_Util is
-- discriminants. Otherwise all components of the parent must be included
-- in the subtype for semantic analysis.
- 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 Get_Actual_Subtype (N : Node_Id) return Entity_Id;
-- Given a node for an expression, obtain the actual subtype of the
-- expression. In the case of a parameter where the formal is an
@@ -1393,18 +1335,6 @@ package Sem_Util is
-- don't look inside packed array types. If Recurse is False, just
-- go down one level (so it's no longer the "fullest" view).
- 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
- -- conservative predicate, if it is not known whether or not T contains
- -- access values (happens for generic formals in some cases), then False is
- -- returned. Note that tagged types return False. Even though the tag is
- -- implemented as an access type internally, this function tests only for
- -- access types known to the programmer. See also Has_Tagged_Component.
-
- function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean;
- -- Returns True if Typ has one or more anonymous access discriminants
-
type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible);
-- Result of Has_Compatible_Alignment test, description found below. Note
-- that the values are arranged in increasing order of problematicness.
@@ -1544,20 +1474,6 @@ package Sem_Util is
-- Return True if the loop has no side effect and can therefore be
-- marked for removal. Return False if N is not a N_Loop_Statement.
- 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;
- 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 Is_Newly_Constructed
(Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean;
-- Indicates whether a given expression is "newly constructed" (RM 4.4).
@@ -1644,11 +1560,6 @@ package Sem_Util is
-- a tagged type or has a subcomponent that is tagged. Returns False for a
-- noncomposite type, or if no tagged subcomponents are present.
- function Has_Unconstrained_Access_Discriminants
- (Subtyp : Entity_Id) return Boolean;
- -- Returns True if the given subtype is unconstrained and has one or more
- -- access discriminants.
-
function Has_Undefined_Reference (Expr : Node_Id) return Boolean;
-- Given arbitrary expression Expr, determine whether it contains at
-- least one name whose entity is Any_Id.
@@ -1822,10 +1733,6 @@ package Sem_Util is
-- pragma Initialize_Scalars or by the binder. Return an expression created
-- at source location Loc, which denotes the invalid value.
- function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean;
- -- Determine if N is used as an actual for a call whose corresponding
- -- formal is of an anonymous access type.
-
function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean;
-- True if E is the constructed wrapper for an access_to_subprogram
-- type with Pre/Postconditions.
@@ -2400,21 +2307,6 @@ package Sem_Util is
-- Determine whether arbitrary entity Id denotes the anonymous object
-- created for a single task type.
- function Is_Special_Aliased_Formal_Access
- (Exp : Node_Id;
- In_Return_Context : Boolean := False) return Boolean;
- -- Determines whether a dynamic check must be generated for explicitly
- -- aliased formals within a function Scop for the expression Exp.
-
- -- In_Return_Context forces Is_Special_Aliased_Formal_Access to assume
- -- that Exp is within a return value which is useful for checking
- -- expressions within discriminant associations of return objects.
-
- -- More specially, Is_Special_Aliased_Formal_Access checks that Exp is a
- -- 'Access attribute reference within a return statement where the ultimate
- -- prefix is an aliased formal of Scop and that Scop returns an anonymous
- -- access type. See RM 3.10.2 for more details.
-
function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean;
-- Determine whether an arbitrary [private] type is specifically tagged
@@ -2692,12 +2584,6 @@ package Sem_Util is
-- syntactic ambiguity that results from an indexing of a function call
-- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y).
- function Needs_Result_Accessibility_Level
- (Func_Id : Entity_Id) return Boolean;
- -- Ada 2012 (AI05-0234): Return True if the function needs an implicit
- -- parameter to identify the accessibility level of the function result
- -- "determined by the point of call".
-
function Needs_Secondary_Stack (Id : Entity_Id) return Boolean;
-- Return true if functions whose result type is Id must return on the
-- secondary stack, i.e. allocate the return object on this stack.
@@ -3340,9 +3226,6 @@ package Sem_Util is
-- Determine whether node N is a loop statement subject to at least one
-- 'Loop_Entry attribute.
- function Subprogram_Access_Level (Subp : Entity_Id) return Uint;
- -- Return the accessibility level of the view denoted by Subp
-
function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean;
-- Return True if Typ supports the GCC built-in atomic operations (i.e. if
-- Typ is properly sized and aligned).
@@ -3373,19 +3256,6 @@ package Sem_Util is
-- returned, i.e. Traverse_More_Func is called and the result is simply
-- discarded.
- function Type_Access_Level
- (Typ : Entity_Id;
- Allow_Alt_Model : Boolean := True;
- Assoc_Ent : Entity_Id := Empty) return Uint;
- -- Return the accessibility level of Typ
-
- -- The Allow_Alt_Model parameter allows the alternative level calculation
- -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
-
- -- 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.
-
function Type_Without_Stream_Operation
(T : Entity_Id;
Op : TSS_Name_Type := TSS_Null) return Entity_Id;
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Accessibility; use Accessibility;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
@@ -953,6 +953,11 @@ package Sinfo is
-- Present in N_Simple_Return_Statement nodes. True if this node was
-- constructed as part of the N_Extended_Return_Statement expansion.
+ -- Comes_From_Iterator
+ -- Present in N_Object_Renaming_Declaration nodes. True if this node was
+ -- was constructed as part of the expansion of an iterator
+ -- specification.
+
-- Compile_Time_Known_Aggregate
-- Present in N_Aggregate nodes. Set for aggregates which can be fully
-- evaluated at compile time without raising constraint error. Such