| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- A C C E S S I B I L I T Y -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2022-2023, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Checks; use Checks; |
| with Debug; use Debug; |
| with Einfo; use Einfo; |
| with Einfo.Entities; use Einfo.Entities; |
| with Elists; use Elists; |
| with Errout; use Errout; |
| with Einfo.Utils; use Einfo.Utils; |
| with Exp_Atag; use Exp_Atag; |
| with Exp_Ch3; use Exp_Ch3; |
| with Exp_Ch7; use Exp_Ch7; |
| with Exp_Tss; use Exp_Tss; |
| with Exp_Util; use Exp_Util; |
| with Namet; use Namet; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Restrict; use Restrict; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Res; use Sem_Res; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| with Tbuild; use Tbuild; |
| |
| package body Accessibility is |
| |
| --------------------------- |
| -- Accessibility_Message -- |
| --------------------------- |
| |
| procedure Accessibility_Message (N : Node_Id; Typ : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| P : constant Node_Id := Prefix (N); |
| Indic : Node_Id := Parent (Parent (N)); |
| |
| begin |
| -- In an instance, this is a runtime check, but one we know will fail, |
| -- so generate an appropriate warning. |
| |
| if In_Instance_Body then |
| Error_Msg_Warn := SPARK_Mode /= On; |
| Error_Msg_F |
| ("non-local pointer cannot point to local object<<", P); |
| Error_Msg_F ("\Program_Error [<<", P); |
| Rewrite (N, |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Accessibility_Check_Failed)); |
| Set_Etype (N, Typ); |
| return; |
| |
| else |
| Error_Msg_F ("non-local pointer cannot point to local object", P); |
| |
| -- Check for case where we have a missing access definition |
| |
| if Is_Record_Type (Current_Scope) |
| and then |
| Nkind (Parent (N)) in N_Discriminant_Association |
| | N_Index_Or_Discriminant_Constraint |
| then |
| Indic := Parent (Parent (N)); |
| while Present (Indic) |
| and then Nkind (Indic) /= N_Subtype_Indication |
| loop |
| Indic := Parent (Indic); |
| end loop; |
| |
| if Present (Indic) then |
| Error_Msg_NE |
| ("\use an access definition for" & |
| " the access discriminant of&", |
| N, Entity (Subtype_Mark (Indic))); |
| end if; |
| end if; |
| end if; |
| end Accessibility_Message; |
| |
| ------------------------- |
| -- Accessibility_Level -- |
| ------------------------- |
| |
| function Accessibility_Level |
| (Expr : Node_Id; |
| Level : Accessibility_Level_Kind; |
| In_Return_Context : Boolean := False; |
| Allow_Alt_Model : Boolean := True) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Expr); |
| |
| function Accessibility_Level (Expr : Node_Id) return Node_Id |
| is (Accessibility_Level (Expr, Level, In_Return_Context)); |
| -- Renaming of the enclosing function to facilitate recursive calls |
| |
| function Make_Level_Literal (Level : Uint) return Node_Id; |
| -- Construct an integer literal representing an accessibility level with |
| -- its type set to Natural. |
| |
| function Innermost_Master_Scope_Depth (N : Node_Id) return Uint; |
| -- Returns the scope depth of the given node's innermost enclosing scope |
| -- (effectively the accessibility level of the innermost enclosing |
| -- master). |
| |
| function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id; |
| -- Centralized processing of subprogram calls which may appear in prefix |
| -- notation. |
| |
| function Typ_Access_Level (Typ : Entity_Id) return Uint |
| is (Type_Access_Level (Typ, Allow_Alt_Model)); |
| -- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid |
| -- passing the parameter specifically in every call. |
| |
| ---------------------------------- |
| -- Innermost_Master_Scope_Depth -- |
| ---------------------------------- |
| |
| function Innermost_Master_Scope_Depth (N : Node_Id) return Uint is |
| Encl_Scop : Entity_Id; |
| Ent : Entity_Id; |
| Node_Par : Node_Id := Parent (N); |
| Master_Lvl_Modifier : Int := 0; |
| |
| begin |
| -- Locate the nearest enclosing node (by traversing Parents) |
| -- that Defining_Entity can be applied to, and return the |
| -- depth of that entity's nearest enclosing scope. |
| |
| -- The RM 7.6.1(3) definition of "master" includes statements |
| -- and conditions for loops among other things. Are these cases |
| -- detected properly ??? |
| |
| while Present (Node_Par) loop |
| Ent := Defining_Entity_Or_Empty (Node_Par); |
| |
| if Present (Ent) then |
| Encl_Scop := Find_Enclosing_Scope (Ent); |
| |
| -- Ignore transient scopes made during expansion while also |
| -- taking into account certain expansions - like iterators |
| -- which get expanded into renamings and thus not marked |
| -- as coming from source. |
| |
| if Comes_From_Source (Node_Par) |
| or else (Nkind (Node_Par) = N_Object_Renaming_Declaration |
| and then Comes_From_Iterator (Node_Par)) |
| then |
| -- Note that in some rare cases the scope depth may not be |
| -- set, for example, when we are in the middle of analyzing |
| -- a type and the enclosing scope is said type. So, instead, |
| -- continue to move up the parent chain since the scope |
| -- depth of the type's parent is the same as that of the |
| -- type. |
| |
| if not Scope_Depth_Set (Encl_Scop) then |
| pragma Assert (Nkind (Parent (Encl_Scop)) |
| = N_Full_Type_Declaration); |
| else |
| return |
| Scope_Depth (Encl_Scop) + Master_Lvl_Modifier; |
| end if; |
| end if; |
| |
| -- For a return statement within a function, return |
| -- the depth of the function itself. This is not just |
| -- a small optimization, but matters when analyzing |
| -- the expression in an expression function before |
| -- the body is created. |
| |
| elsif Nkind (Node_Par) in N_Extended_Return_Statement |
| | N_Simple_Return_Statement |
| then |
| return Scope_Depth (Enclosing_Subprogram (Node_Par)); |
| |
| -- Statements are counted as masters |
| |
| elsif Is_Master (Node_Par) then |
| Master_Lvl_Modifier := Master_Lvl_Modifier + 1; |
| |
| end if; |
| |
| Node_Par := Parent (Node_Par); |
| end loop; |
| |
| -- Should never reach the following return |
| |
| pragma Assert (False); |
| |
| return Scope_Depth (Current_Scope) + 1; |
| end Innermost_Master_Scope_Depth; |
| |
| ------------------------ |
| -- Make_Level_Literal -- |
| ------------------------ |
| |
| function Make_Level_Literal (Level : Uint) return Node_Id is |
| Result : constant Node_Id := Make_Integer_Literal (Loc, Level); |
| |
| begin |
| Set_Etype (Result, Standard_Natural); |
| return Result; |
| end Make_Level_Literal; |
| |
| -------------------------------------- |
| -- Function_Call_Or_Allocator_Level -- |
| -------------------------------------- |
| |
| function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id is |
| Par : Node_Id; |
| Prev_Par : Node_Id; |
| begin |
| -- Results of functions are objects, so we either get the |
| -- accessibility of the function or, in case of a call which is |
| -- indirect, the level of the access-to-subprogram type. |
| |
| -- This code looks wrong ??? |
| |
| if Nkind (N) = N_Function_Call |
| and then Ada_Version < Ada_2005 |
| then |
| if Is_Entity_Name (Name (N)) then |
| return Make_Level_Literal |
| (Subprogram_Access_Level (Entity (Name (N)))); |
| else |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (Prefix (Name (N))))); |
| end if; |
| |
| -- We ignore coextensions as they cannot be implemented under the |
| -- "small-integer" model. |
| |
| elsif Nkind (N) = N_Allocator |
| and then (Is_Static_Coextension (N) |
| or else Is_Dynamic_Coextension (N)) |
| then |
| return Make_Level_Literal (Scope_Depth (Standard_Standard)); |
| end if; |
| |
| -- Named access types have a designated level |
| |
| if Is_Named_Access_Type (Etype (N)) then |
| return Make_Level_Literal (Typ_Access_Level (Etype (N))); |
| |
| -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3) |
| |
| else |
| -- Check No_Dynamic_Accessibility_Checks restriction override for |
| -- alternative accessibility model. |
| |
| if Allow_Alt_Model |
| and then No_Dynamic_Accessibility_Checks_Enabled (N) |
| and then Is_Anonymous_Access_Type (Etype (N)) |
| then |
| -- In the alternative model the level is that of the |
| -- designated type. |
| |
| if Debug_Flag_Underscore_B then |
| return Make_Level_Literal (Typ_Access_Level (Etype (N))); |
| |
| -- For function calls the level is that of the innermost |
| -- master, otherwise (for allocators etc.) we get the level |
| -- of the corresponding anonymous access type, which is |
| -- calculated through the normal path of execution. |
| |
| elsif Nkind (N) = N_Function_Call then |
| return Make_Level_Literal |
| (Innermost_Master_Scope_Depth (Expr)); |
| end if; |
| end if; |
| |
| if Nkind (N) = N_Function_Call then |
| -- Dynamic checks are generated when we are within a return |
| -- value or we are in a function call within an anonymous |
| -- access discriminant constraint of a return object (signified |
| -- by In_Return_Context) on the side of the callee. |
| |
| -- So, in this case, return accessibility level of the |
| -- enclosing subprogram. |
| |
| if In_Return_Value (N) |
| or else In_Return_Context |
| then |
| return Make_Level_Literal |
| (Subprogram_Access_Level (Current_Subprogram)); |
| end if; |
| end if; |
| |
| -- When the call is being dereferenced the level is that of the |
| -- enclosing master of the dereferenced call. |
| |
| if Nkind (Parent (N)) in N_Explicit_Dereference |
| | N_Indexed_Component |
| | N_Selected_Component |
| then |
| return Make_Level_Literal |
| (Innermost_Master_Scope_Depth (Expr)); |
| end if; |
| |
| -- Find any relevant enclosing parent nodes that designate an |
| -- object being initialized. |
| |
| -- Note: The above is only relevant if the result is used "in its |
| -- entirety" as RM 3.10.2 (10.2/3) states. However, this is |
| -- accounted for in the case statement in the main body of |
| -- Accessibility_Level for N_Selected_Component. |
| |
| Par := Parent (Expr); |
| Prev_Par := Empty; |
| while Present (Par) loop |
| -- Detect an expanded implicit conversion, typically this |
| -- occurs on implicitly converted actuals in calls. |
| |
| -- Does this catch all implicit conversions ??? |
| |
| if Nkind (Par) = N_Type_Conversion |
| and then Is_Named_Access_Type (Etype (Par)) |
| then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (Par))); |
| end if; |
| |
| -- Jump out when we hit an object declaration or the right-hand |
| -- side of an assignment, or a construct such as an aggregate |
| -- subtype indication which would be the result is not used |
| -- "in its entirety." |
| |
| exit when Nkind (Par) in N_Object_Declaration |
| or else (Nkind (Par) = N_Assignment_Statement |
| and then Name (Par) /= Prev_Par); |
| |
| Prev_Par := Par; |
| Par := Parent (Par); |
| end loop; |
| |
| -- Assignment statements are handled in a similar way in |
| -- accordance to the left-hand part. However, strictly speaking, |
| -- this is illegal according to the RM, but this change is needed |
| -- to pass an ACATS C-test and is useful in general ??? |
| |
| case Nkind (Par) is |
| when N_Object_Declaration => |
| return Make_Level_Literal |
| (Scope_Depth |
| (Scope (Defining_Identifier (Par)))); |
| |
| when N_Assignment_Statement => |
| -- Return the accessibility level of the left-hand part |
| |
| return Accessibility_Level |
| (Expr => Name (Par), |
| Level => Object_Decl_Level, |
| In_Return_Context => In_Return_Context); |
| |
| when others => |
| return Make_Level_Literal |
| (Innermost_Master_Scope_Depth (Expr)); |
| end case; |
| end if; |
| end Function_Call_Or_Allocator_Level; |
| |
| -- Local variables |
| |
| E : Node_Id := Original_Node (Expr); |
| Pre : Node_Id; |
| |
| -- Start of processing for Accessibility_Level |
| |
| begin |
| -- We could be looking at a reference to a formal due to the expansion |
| -- of entries and other cases, so obtain the renaming if necessary. |
| |
| if Present (Param_Entity (Expr)) then |
| E := Param_Entity (Expr); |
| end if; |
| |
| -- Extract the entity |
| |
| if Nkind (E) in N_Has_Entity and then Present (Entity (E)) then |
| E := Entity (E); |
| |
| -- Deal with a possible renaming of a private protected component |
| |
| if Ekind (E) in E_Constant | E_Variable and then Is_Prival (E) then |
| E := Prival_Link (E); |
| end if; |
| end if; |
| |
| -- Perform the processing on the expression |
| |
| case Nkind (E) is |
| -- The level of an aggregate is that of the innermost master that |
| -- evaluates it as defined in RM 3.10.2 (10/4). |
| |
| when N_Aggregate => |
| return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr)); |
| |
| -- The accessibility level is that of the access type, except for an |
| -- anonymous allocators which have special rules defined in RM 3.10.2 |
| -- (14/3). |
| |
| when N_Allocator => |
| return Function_Call_Or_Allocator_Level (E); |
| |
| -- We could reach this point for two reasons. Either the expression |
| -- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or |
| -- we are looking at the access attributes directly ('Access, |
| -- 'Address, or 'Unchecked_Access). |
| |
| when N_Attribute_Reference => |
| Pre := Original_Node (Prefix (E)); |
| |
| -- Regular 'Access attribute presence means we have to look at the |
| -- prefix. |
| |
| if Attribute_Name (E) = Name_Access then |
| return Accessibility_Level (Prefix (E)); |
| |
| -- Unchecked or unrestricted attributes have unlimited depth |
| |
| elsif Attribute_Name (E) in Name_Address |
| | Name_Unchecked_Access |
| | Name_Unrestricted_Access |
| then |
| return Make_Level_Literal (Scope_Depth (Standard_Standard)); |
| |
| -- 'Access can be taken further against other special attributes, |
| -- so handle these cases explicitly. |
| |
| elsif Attribute_Name (E) |
| in Name_Old | Name_Loop_Entry | Name_Result |
| then |
| -- Named access types |
| |
| if Is_Named_Access_Type (Etype (Pre)) then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (Pre))); |
| |
| -- Anonymous access types |
| |
| elsif Nkind (Pre) in N_Has_Entity |
| and then Ekind (Entity (Pre)) not in Subprogram_Kind |
| and then Present (Get_Dynamic_Accessibility (Entity (Pre))) |
| and then Level = Dynamic_Level |
| then |
| return New_Occurrence_Of |
| (Get_Dynamic_Accessibility (Entity (Pre)), Loc); |
| |
| -- Otherwise the level is treated in a similar way as |
| -- aggregates according to RM 6.1.1 (35.1/4) which concerns |
| -- an implicit constant declaration - in turn defining the |
| -- accessibility level to be that of the implicit constant |
| -- declaration. |
| |
| else |
| return Make_Level_Literal |
| (Innermost_Master_Scope_Depth (Expr)); |
| end if; |
| |
| else |
| raise Program_Error; |
| end if; |
| |
| -- This is the "base case" for accessibility level calculations which |
| -- means we are near the end of our recursive traversal. |
| |
| when N_Defining_Identifier => |
| -- A dynamic check is performed on the side of the callee when we |
| -- are within a return statement, so return a library-level |
| -- accessibility level to null out checks on the side of the |
| -- caller. |
| |
| if Is_Explicitly_Aliased (E) |
| and then (In_Return_Context |
| or else (Level /= Dynamic_Level |
| and then In_Return_Value (Expr))) |
| then |
| return Make_Level_Literal (Scope_Depth (Standard_Standard)); |
| |
| -- Something went wrong and an extra accessibility formal has not |
| -- been generated when one should have ??? |
| |
| elsif Is_Formal (E) |
| and then No (Get_Dynamic_Accessibility (E)) |
| and then Ekind (Etype (E)) = E_Anonymous_Access_Type |
| then |
| return Make_Level_Literal (Scope_Depth (Standard_Standard)); |
| |
| -- Stand-alone object of an anonymous access type "SAOAAT" |
| |
| elsif (Is_Formal (E) |
| or else Ekind (E) in E_Variable |
| | E_Constant) |
| and then Present (Get_Dynamic_Accessibility (E)) |
| and then (Level = Dynamic_Level |
| or else Level = Zero_On_Dynamic_Level) |
| then |
| if Level = Zero_On_Dynamic_Level then |
| return Make_Level_Literal |
| (Scope_Depth (Standard_Standard)); |
| end if; |
| |
| -- No_Dynamic_Accessibility_Checks restriction override for |
| -- alternative accessibility model. |
| |
| if Allow_Alt_Model |
| and then No_Dynamic_Accessibility_Checks_Enabled (E) |
| then |
| -- In the alternative model the level is that of the |
| -- designated type entity's context. |
| |
| if Debug_Flag_Underscore_B then |
| return Make_Level_Literal (Typ_Access_Level (Etype (E))); |
| |
| -- Otherwise the level depends on the entity's context |
| |
| elsif Is_Formal (E) then |
| return Make_Level_Literal |
| (Subprogram_Access_Level |
| (Enclosing_Subprogram (E))); |
| else |
| return Make_Level_Literal |
| (Scope_Depth (Enclosing_Dynamic_Scope (E))); |
| end if; |
| end if; |
| |
| -- Return the dynamic level in the normal case |
| |
| return New_Occurrence_Of |
| (Get_Dynamic_Accessibility (E), Loc); |
| |
| -- Initialization procedures have a special extra accessibility |
| -- parameter associated with the level at which the object |
| -- being initialized exists |
| |
| elsif Ekind (E) = E_Record_Type |
| and then Is_Limited_Record (E) |
| and then Current_Scope = Init_Proc (E) |
| and then Present (Init_Proc_Level_Formal (Current_Scope)) |
| then |
| return New_Occurrence_Of |
| (Init_Proc_Level_Formal (Current_Scope), Loc); |
| |
| -- Current instance of the type is deeper than that of the type |
| -- according to RM 3.10.2 (21). |
| |
| elsif Is_Type (E) then |
| -- When restriction No_Dynamic_Accessibility_Checks is active |
| -- along with -gnatd_b. |
| |
| if Allow_Alt_Model |
| and then No_Dynamic_Accessibility_Checks_Enabled (E) |
| and then Debug_Flag_Underscore_B |
| then |
| return Make_Level_Literal (Typ_Access_Level (E)); |
| end if; |
| |
| -- Normal path |
| |
| return Make_Level_Literal (Typ_Access_Level (E) + 1); |
| |
| -- Move up the renamed entity or object if it came from source |
| -- since expansion may have created a dummy renaming under |
| -- certain circumstances. |
| |
| -- Note: We check if the original node of the renaming comes |
| -- from source because the node may have been rewritten. |
| |
| elsif Present (Renamed_Entity_Or_Object (E)) |
| and then Comes_From_Source |
| (Original_Node (Renamed_Entity_Or_Object (E))) |
| then |
| return Accessibility_Level (Renamed_Entity_Or_Object (E)); |
| |
| -- Named access types get their level from their associated type |
| |
| elsif Is_Named_Access_Type (Etype (E)) then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (E))); |
| |
| -- Check if E is an expansion-generated renaming of an iterator |
| -- by examining Related_Expression. If so, determine the |
| -- accessibility level based on the original expression. |
| |
| elsif Ekind (E) in E_Constant | E_Variable |
| and then Present (Related_Expression (E)) |
| then |
| return Accessibility_Level (Related_Expression (E)); |
| |
| elsif Level = Dynamic_Level |
| and then Ekind (E) in E_In_Parameter | E_In_Out_Parameter |
| and then Present (Init_Proc_Level_Formal (Scope (E))) |
| then |
| return New_Occurrence_Of |
| (Init_Proc_Level_Formal (Scope (E)), Loc); |
| |
| -- Normal object - get the level of the enclosing scope |
| |
| else |
| return Make_Level_Literal |
| (Scope_Depth (Enclosing_Dynamic_Scope (E))); |
| end if; |
| |
| -- Handle indexed and selected components including the special cases |
| -- whereby there is an implicit dereference, a component of a |
| -- composite type, or a function call in prefix notation. |
| |
| -- We don't handle function calls in prefix notation correctly ??? |
| |
| when N_Indexed_Component | N_Selected_Component | N_Slice => |
| Pre := Prefix (E); |
| |
| -- Fetch the original node when the prefix comes from the result |
| -- of expanding a function call since we want to find the level |
| -- of the original source call. |
| |
| if not Comes_From_Source (Pre) |
| and then Nkind (Original_Node (Pre)) = N_Function_Call |
| then |
| Pre := Original_Node (Pre); |
| end if; |
| |
| -- When E is an indexed component or selected component and |
| -- the current Expr is a function call, we know that we are |
| -- looking at an expanded call in prefix notation. |
| |
| if Nkind (Expr) = N_Function_Call then |
| return Function_Call_Or_Allocator_Level (Expr); |
| |
| -- If the prefix is a named access type, then we are dealing |
| -- with an implicit deferences. In that case the level is that |
| -- of the named access type in the prefix. |
| |
| elsif Is_Named_Access_Type (Etype (Pre)) then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (Pre))); |
| |
| -- The current expression is a named access type, so there is no |
| -- reason to look at the prefix. Instead obtain the level of E's |
| -- named access type. |
| |
| elsif Is_Named_Access_Type (Etype (E)) then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (E))); |
| |
| -- A nondiscriminant selected component where the component |
| -- is an anonymous access type means that its associated |
| -- level is that of the containing type - see RM 3.10.2 (16). |
| |
| -- Note that when restriction No_Dynamic_Accessibility_Checks is |
| -- in effect we treat discriminant components as regular |
| -- components. |
| |
| elsif |
| (Nkind (E) = N_Selected_Component |
| and then Ekind (Etype (E)) = E_Anonymous_Access_Type |
| and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type |
| and then (not (Nkind (Selector_Name (E)) in N_Has_Entity |
| and then Ekind (Entity (Selector_Name (E))) |
| = E_Discriminant) |
| |
| -- The alternative accessibility models both treat |
| -- discriminants as regular components. |
| |
| or else (No_Dynamic_Accessibility_Checks_Enabled (E) |
| and then Allow_Alt_Model))) |
| |
| -- Arrays featuring components of anonymous access components |
| -- get their corresponding level from their containing type's |
| -- declaration. |
| |
| or else |
| (Nkind (E) = N_Indexed_Component |
| and then Ekind (Etype (E)) = E_Anonymous_Access_Type |
| and then Ekind (Etype (Pre)) in Array_Kind |
| and then Ekind (Component_Type (Base_Type (Etype (Pre)))) |
| = E_Anonymous_Access_Type) |
| then |
| -- When restriction No_Dynamic_Accessibility_Checks is active |
| -- and -gnatd_b set, the level is that of the designated type. |
| |
| if Allow_Alt_Model |
| and then No_Dynamic_Accessibility_Checks_Enabled (E) |
| and then Debug_Flag_Underscore_B |
| then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (E))); |
| end if; |
| |
| -- Otherwise proceed normally |
| |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (Prefix (E)))); |
| |
| -- The accessibility calculation routine that handles function |
| -- calls (Function_Call_Level) assumes, in the case the |
| -- result is of an anonymous access type, that the result will be |
| -- used "in its entirety" when the call is present within an |
| -- assignment or object declaration. |
| |
| -- To properly handle cases where the result is not used in its |
| -- entirety, we test if the prefix of the component in question is |
| -- a function call, which tells us that one of its components has |
| -- been identified and is being accessed. Therefore we can |
| -- conclude that the result is not used "in its entirety" |
| -- according to RM 3.10.2 (10.2/3). |
| |
| elsif Nkind (Pre) = N_Function_Call |
| and then not Is_Named_Access_Type (Etype (Pre)) |
| then |
| -- Dynamic checks are generated when we are within a return |
| -- value or we are in a function call within an anonymous |
| -- access discriminant constraint of a return object (signified |
| -- by In_Return_Context) on the side of the callee. |
| |
| -- So, in this case, return a library accessibility level to |
| -- null out the check on the side of the caller. |
| |
| if (In_Return_Value (E) |
| or else In_Return_Context) |
| and then Level /= Dynamic_Level |
| then |
| return Make_Level_Literal |
| (Scope_Depth (Standard_Standard)); |
| end if; |
| |
| return Make_Level_Literal |
| (Innermost_Master_Scope_Depth (Expr)); |
| |
| -- Otherwise, continue recursing over the expression prefixes |
| |
| else |
| return Accessibility_Level (Prefix (E)); |
| end if; |
| |
| -- Qualified expressions |
| |
| when N_Qualified_Expression => |
| if Is_Named_Access_Type (Etype (E)) then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (E))); |
| else |
| return Accessibility_Level (Expression (E)); |
| end if; |
| |
| -- Handle function calls |
| |
| when N_Function_Call => |
| return Function_Call_Or_Allocator_Level (E); |
| |
| -- Explicit dereference accessibility level calculation |
| |
| when N_Explicit_Dereference => |
| Pre := Original_Node (Prefix (E)); |
| |
| -- The prefix is a named access type so the level is taken from |
| -- its type. |
| |
| if Is_Named_Access_Type (Etype (Pre)) then |
| return Make_Level_Literal (Typ_Access_Level (Etype (Pre))); |
| |
| -- Otherwise, recurse deeper |
| |
| else |
| return Accessibility_Level (Prefix (E)); |
| end if; |
| |
| -- Type conversions |
| |
| when N_Type_Conversion | N_Unchecked_Type_Conversion => |
| -- View conversions are special in that they require use to |
| -- inspect the expression of the type conversion. |
| |
| -- Allocators of anonymous access types are internally generated, |
| -- so recurse deeper in that case as well. |
| |
| if Is_View_Conversion (E) |
| or else Ekind (Etype (E)) = E_Anonymous_Access_Type |
| then |
| return Accessibility_Level (Expression (E)); |
| |
| -- We don't care about the master if we are looking at a named |
| -- access type. |
| |
| elsif Is_Named_Access_Type (Etype (E)) then |
| return Make_Level_Literal |
| (Typ_Access_Level (Etype (E))); |
| |
| -- In section RM 3.10.2 (10/4) the accessibility rules for |
| -- aggregates and value conversions are outlined. Are these |
| -- followed in the case of initialization of an object ??? |
| |
| -- Should use Innermost_Master_Scope_Depth ??? |
| |
| else |
| return Accessibility_Level (Current_Scope); |
| end if; |
| |
| -- Default to the type accessibility level for the type of the |
| -- expression's entity. |
| |
| when others => |
| return Make_Level_Literal (Typ_Access_Level (Etype (E))); |
| end case; |
| end Accessibility_Level; |
| |
| ------------------------------- |
| -- Apply_Accessibility_Check -- |
| ------------------------------- |
| |
| procedure Apply_Accessibility_Check |
| (N : Node_Id; |
| Typ : Entity_Id; |
| Insert_Node : Node_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Check_Cond : Node_Id; |
| Param_Ent : Entity_Id := Param_Entity (N); |
| Param_Level : Node_Id; |
| Type_Level : Node_Id; |
| |
| begin |
| -- Verify we haven't tried to add a dynamic accessibility check when we |
| -- shouldn't. |
| |
| pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N)); |
| |
| if Ada_Version >= Ada_2012 |
| and then No (Param_Ent) |
| and then Is_Entity_Name (N) |
| and then Ekind (Entity (N)) in E_Constant | E_Variable |
| and then Present (Effective_Extra_Accessibility (Entity (N))) |
| then |
| Param_Ent := Entity (N); |
| while Present (Renamed_Object (Param_Ent)) loop |
| -- Renamed_Object must return an Entity_Name here |
| -- because of preceding "Present (E_E_A (...))" test. |
| |
| Param_Ent := Entity (Renamed_Object (Param_Ent)); |
| end loop; |
| end if; |
| |
| if Inside_A_Generic then |
| return; |
| |
| -- Only apply the run-time check if the access parameter has an |
| -- associated extra access level parameter and when accessibility checks |
| -- are enabled. |
| |
| elsif Present (Param_Ent) |
| and then Present (Get_Dynamic_Accessibility (Param_Ent)) |
| and then not Accessibility_Checks_Suppressed (Param_Ent) |
| and then not Accessibility_Checks_Suppressed (Typ) |
| then |
| -- Obtain the parameter's accessibility level |
| |
| Param_Level := |
| New_Occurrence_Of (Get_Dynamic_Accessibility (Param_Ent), Loc); |
| |
| -- Use the dynamic accessibility parameter for the function's result |
| -- when one has been created instead of statically referring to the |
| -- deepest type level so as to appropriatly handle the rules for |
| -- RM 3.10.2 (10.1/3). |
| |
| if Ekind (Scope (Param_Ent)) = E_Function |
| and then In_Return_Value (N) |
| and then Ekind (Typ) = E_Anonymous_Access_Type |
| then |
| -- Associate the level of the result type to the extra result |
| -- accessibility parameter belonging to the current function. |
| |
| if Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then |
| Type_Level := |
| New_Occurrence_Of |
| (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc); |
| |
| -- In Ada 2005 and earlier modes, a result extra accessibility |
| -- parameter is not generated and no dynamic check is performed. |
| |
| else |
| return; |
| end if; |
| |
| -- Otherwise get the type's accessibility level normally |
| |
| else |
| Type_Level := |
| Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ)); |
| end if; |
| |
| -- Raise Program_Error if the accessibility level of the access |
| -- parameter is deeper than the level of the target access type. |
| |
| Check_Cond := |
| Make_Op_Gt (Loc, |
| Left_Opnd => Param_Level, |
| Right_Opnd => Type_Level); |
| |
| Insert_Action (Insert_Node, |
| Make_Raise_Program_Error (Loc, |
| Condition => Check_Cond, |
| Reason => PE_Accessibility_Check_Failed)); |
| |
| Analyze_And_Resolve (N); |
| |
| -- If constant folding has happened on the condition for the |
| -- generated error, then warn about it being unconditional. |
| |
| if Nkind (Check_Cond) = N_Identifier |
| and then Entity (Check_Cond) = Standard_True |
| then |
| Error_Msg_Warn := SPARK_Mode /= On; |
| Error_Msg_N ("accessibility check fails<<", N); |
| Error_Msg_N ("\Program_Error [<<", N); |
| end if; |
| end if; |
| end Apply_Accessibility_Check; |
| |
| --------------------------------------------- |
| -- Apply_Accessibility_Check_For_Allocator -- |
| --------------------------------------------- |
| |
| procedure Apply_Accessibility_Check_For_Allocator |
| (N : Node_Id; |
| Exp : Node_Id; |
| Ref : Node_Id; |
| Built_In_Place : Boolean := False) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| PtrT : constant Entity_Id := Etype (N); |
| DesigT : constant Entity_Id := Designated_Type (PtrT); |
| Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT); |
| Cond : Node_Id; |
| Fin_Call : Node_Id; |
| Free_Stmt : Node_Id; |
| Obj_Ref : Node_Id; |
| Stmts : List_Id; |
| |
| begin |
| if Ada_Version >= Ada_2005 |
| and then Is_Class_Wide_Type (DesigT) |
| and then Tagged_Type_Expansion |
| and then not Scope_Suppress.Suppress (Accessibility_Check) |
| and then not No_Dynamic_Accessibility_Checks_Enabled (Ref) |
| and then |
| (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT) |
| or else |
| (Is_Class_Wide_Type (Etype (Exp)) |
| and then Scope (PtrT) /= Current_Scope)) |
| then |
| -- If the allocator was built in place, Ref is already a reference |
| -- to the access object initialized to the result of the allocator |
| -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call |
| -- Remove_Side_Effects for cases where the build-in-place call may |
| -- still be the prefix of the reference (to avoid generating |
| -- duplicate calls). Otherwise, it is the entity associated with |
| -- the object containing the address of the allocated object. |
| |
| if Built_In_Place then |
| Remove_Side_Effects (Ref); |
| Obj_Ref := New_Copy_Tree (Ref); |
| else |
| Obj_Ref := New_Occurrence_Of (Ref, Loc); |
| end if; |
| |
| -- For access to interface types we must generate code to displace |
| -- the pointer to the base of the object since the subsequent code |
| -- references components located in the TSD of the object (which |
| -- is associated with the primary dispatch table --see a-tags.ads) |
| -- and also generates code invoking Free, which requires also a |
| -- reference to the base of the unallocated object. |
| |
| if Is_Interface (DesigT) and then Tagged_Type_Expansion then |
| Obj_Ref := |
| Unchecked_Convert_To (Etype (Obj_Ref), |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Base_Address), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Address), |
| New_Copy_Tree (Obj_Ref))))); |
| end if; |
| |
| -- Step 1: Create the object clean up code |
| |
| Stmts := New_List; |
| |
| -- Deallocate the object if the accessibility check fails. This is |
| -- done only on targets or profiles that support deallocation. |
| |
| -- Free (Obj_Ref); |
| |
| if RTE_Available (RE_Free) then |
| Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref)); |
| Set_Storage_Pool (Free_Stmt, Pool_Id); |
| |
| Append_To (Stmts, Free_Stmt); |
| |
| -- The target or profile cannot deallocate objects |
| |
| else |
| Free_Stmt := Empty; |
| end if; |
| |
| -- Finalize the object if applicable. Generate: |
| |
| -- [Deep_]Finalize (Obj_Ref.all); |
| |
| if Needs_Finalization (DesigT) |
| and then not No_Heap_Finalization (PtrT) |
| then |
| Fin_Call := |
| Make_Final_Call |
| (Obj_Ref => |
| Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)), |
| Typ => DesigT); |
| |
| -- Guard against a missing [Deep_]Finalize when the designated |
| -- type was not properly frozen. |
| |
| if No (Fin_Call) then |
| Fin_Call := Make_Null_Statement (Loc); |
| end if; |
| |
| -- When the target or profile supports deallocation, wrap the |
| -- finalization call in a block to ensure proper deallocation even |
| -- if finalization fails. Generate: |
| |
| -- begin |
| -- <Fin_Call> |
| -- exception |
| -- when others => |
| -- <Free_Stmt> |
| -- raise; |
| -- end; |
| |
| if Present (Free_Stmt) then |
| Fin_Call := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Fin_Call), |
| |
| Exception_Handlers => New_List ( |
| Make_Exception_Handler (Loc, |
| Exception_Choices => New_List ( |
| Make_Others_Choice (Loc)), |
| Statements => New_List ( |
| New_Copy_Tree (Free_Stmt), |
| Make_Raise_Statement (Loc)))))); |
| end if; |
| |
| Prepend_To (Stmts, Fin_Call); |
| end if; |
| |
| -- Signal the accessibility failure through a Program_Error |
| |
| Append_To (Stmts, |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Accessibility_Check_Failed)); |
| |
| -- Step 2: Create the accessibility comparison |
| |
| -- Generate: |
| -- Ref'Tag |
| |
| Obj_Ref := |
| Make_Attribute_Reference (Loc, |
| Prefix => Obj_Ref, |
| Attribute_Name => Name_Tag); |
| |
| -- For tagged types, determine the accessibility level by looking at |
| -- the type specific data of the dispatch table. Generate: |
| |
| -- Type_Specific_Data (Address (Ref'Tag)).Access_Level |
| |
| if Tagged_Type_Expansion then |
| Cond := Build_Get_Access_Level (Loc, Obj_Ref); |
| |
| -- Use a runtime call to determine the accessibility level when |
| -- compiling on virtual machine targets. Generate: |
| |
| -- Get_Access_Level (Ref'Tag) |
| |
| else |
| Cond := |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc), |
| Parameter_Associations => New_List (Obj_Ref)); |
| end if; |
| |
| Cond := |
| Make_Op_Gt (Loc, |
| Left_Opnd => Cond, |
| Right_Opnd => Accessibility_Level (N, Dynamic_Level)); |
| |
| -- Due to the complexity and side effects of the check, utilize an if |
| -- statement instead of the regular Program_Error circuitry. |
| |
| Insert_Action (N, |
| Make_Implicit_If_Statement (N, |
| Condition => Cond, |
| Then_Statements => Stmts)); |
| end if; |
| end Apply_Accessibility_Check_For_Allocator; |
| |
| ------------------------------------------ |
| -- Check_Return_Construct_Accessibility -- |
| ------------------------------------------ |
| |
| procedure Check_Return_Construct_Accessibility |
| (Return_Stmt : Node_Id; |
| Stm_Entity : Entity_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Return_Stmt); |
| Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity); |
| |
| R_Type : constant Entity_Id := Etype (Scope_Id); |
| -- Function result subtype |
| |
| function First_Selector (Assoc : Node_Id) return Node_Id; |
| -- Obtain the first selector or choice from a given association |
| |
| function Is_Formal_Of_Current_Function |
| (Assoc_Expr : Node_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 : Node_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; |
