diff options
| author | Justin Squirek <squirek@adacore.com> | 2022-11-17 15:34:57 +0000 |
|---|---|---|
| committer | Marc Poulhiès <poulhies@adacore.com> | 2022-12-06 14:58:48 +0100 |
| commit | f459afaa679956df1f3c0243a87583e4d4b43a2e (patch) | |
| tree | a94e0a86c619a30b2465ea1c941b3fcb3554d180 /gcc/ada/accessibility.adb | |
| parent | c690f116b64be820cd47a554bffeadd9907fed2a (diff) | |
| download | gcc-f459afaa679956df1f3c0243a87583e4d4b43a2e.zip gcc-f459afaa679956df1f3c0243a87583e4d4b43a2e.tar.gz gcc-f459afaa679956df1f3c0243a87583e4d4b43a2e.tar.bz2 | |
ada: Accessibility code reorganization and bug fixes
This patch performs a large reorganization of accessibility related sources,
and also corrects some latent issues with accessibility checks - namely the
calculation of accessibility levels for expanded iterators and type
conversions.
gcc/ada/
* accessibility.adb, accessibility.ads
(Accessibility_Message): Moved from sem_attr.
(Apply_Accessibility_Check): Moved from checks.
(Apply_Accessibility_Check_For_Allocator): Moved from exp_ch4 and
renamed
(Check_Return_Construct_Accessibility): Moved from sem_ch6.
(Innermost_Master_Scope_Depth): Moved from sem_util. Add condition
to detect expanded iterators.
(Prefix_With_Safe_Accessibility_Level): Moved from sem_attr.
(Static_Accessibility_Level): Moved from sem_util.
(Has_Unconstrained_Access_Discriminants): Likewise.
(Has_Anonymous_Access_Discriminant): Likewise.
(Is_Anonymous_Access_Actual): Likewise.
(Is_Special_Aliased_Formal_Access): Likewise.
(Needs_Result_Accessibility_Level): Likewise.
(Subprogram_Access_Level): Likewise.
(Type_Access_Level): Likewise.
(Deepest_Type_Access_Level): Likewise.
(Effective_Extra_Accessibility): Likewise.
(Get_Dynamic_Accessibility): Likewise.
(Has_Access_Values): Likewise.
(Accessibility_Level): Likewise.
* exp_attr.adb (Access_Cases): Obtain the proper enclosing object
which applies to a given 'Access by looking through type
conversions.
* exp_ch4.adb (Apply_Accessibility_Check): Moved to accessibility.
* exp_ch5.adb: Likewise.
* exp_ch6.adb: Likewise.
* exp_ch9.adb: Likewise.
* exp_disp.adb: Likewise.
* gen_il-fields.ads: Add new flag Comes_From_Iterator.
* gen_il-gen-gen_nodes.adb: Add new flag Comes_From_Iterator for
N_Object_Renaming_Declaration.
* sem_ch5.adb (Analyze_Iterator_Specification): Mark object
renamings resulting from iterator expansion with the new flag
Comes_From_Iterator.
* sem_aggr.adb (Resolve_Container_Aggregate): Refine test.
* sem_ch13.adb: Add dependence on the accessibility package.
* sem_ch3.adb: Likewise.
* sem_ch4.adb: Likewise.
* sem_ch9.adb: Likewise.
* sem_res.adb: Likewise.
* sem_warn.adb: Likewise.
* exp_ch3.adb: Likewise.
* sem_attr.adb (Accessibility_Message): Moved to accessibility.
(Prefix_With_Safe_Accessibility_Level): Likewise.
* checks.adb, checks.ads (Apply_Accessibility_Check): Likewise.
* sem_ch6.adb (Check_Return_Construct_Accessibility): Likewise.
* sem_util.adb, sem_util.ads
(Accessibility_Level): Likewise.
(Deepest_Type_Access_Level): Likewise.
(Effective_Extra_Accessibility): Likewise.
(Get_Dynamic_Accessibility): Likewise.
(Has_Access_Values): Likewise.
(Has_Anonymous_Access_Discriminant): Likewise.
(Static_Accessibility_Level): Likewise.
(Has_Unconstrained_Access_Discriminants): Likewise.
(Is_Anonymous_Access_Actual): Likewise.
(Is_Special_Aliased_Formal_Access): Likewise.
(Needs_Result_Accessibility_Level): Likewise.
(Subprogram_Access_Level): Likewise.
(Type_Access_Level): Likewise.
* sinfo.ads: Document new flag Comes_From_Iterator.
* gcc-interface/Make-lang.in: Add entry for new Accessibility package.
Diffstat (limited to 'gcc/ada/accessibility.adb')
| -rw-r--r-- | gcc/ada/accessibility.adb | 2305 |
1 files changed, 2305 insertions, 0 deletions
diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb new file mode 100644 index 0000000..3162806 --- /dev/null +++ b/gcc/ada/accessibility.adb @@ -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; |