diff options
| -rw-r--r-- | gcc/ada/accessibility.adb | 2305 | ||||
| -rw-r--r-- | gcc/ada/accessibility.ads | 222 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 113 | ||||
| -rw-r--r-- | gcc/ada/checks.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 223 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 1 | ||||
| -rw-r--r-- | gcc/ada/gen_il-fields.ads | 1 | ||||
| -rw-r--r-- | gcc/ada/gen_il-gen-gen_nodes.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 133 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 519 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 1299 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 130 | ||||
| -rw-r--r-- | gcc/ada/sem_warn.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 5 |
27 files changed, 2577 insertions, 2414 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; diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads new file mode 100644 index 0000000..454ad75 --- /dev/null +++ b/gcc/ada/accessibility.ads @@ -0,0 +1,222 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A C C E S S I B I L I T Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-2022, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Accessibility level and check generation routines + +with Types; use Types; +with Uintp; use Uintp; + +package Accessibility is + + procedure Accessibility_Message (N : Node_Id; Typ : Entity_Id); + -- Error, or warning within an instance, if the static accessibility + -- rules of 3.10.2 are violated. + + type Accessibility_Level_Kind is + (Dynamic_Level, + Object_Decl_Level, + Zero_On_Dynamic_Level); + -- Accessibility_Level_Kind is an enumerated type which captures the + -- different modes in which an accessibility level could be obtained for + -- a given expression. + + -- When in the context of the function Accessibility_Level, + -- Accessibility_Level_Kind signals what type of accessibility level to + -- obtain. For example, when Level is Dynamic_Level, a defining identifier + -- associated with a SAOOAAT may be returned or an N_Integer_Literal node. + -- When the level is Object_Decl_Level, an N_Integer_Literal node is + -- returned containing the level of the declaration of the object if + -- relevant (be it a SAOOAAT or otherwise). Finally, Zero_On_Dynamic_Level + -- returns library level for all cases where the accessibility level is + -- dynamic (used to bypass static accessibility checks in dynamic cases). + + function Accessibility_Level + (Expr : Node_Id; + Level : Accessibility_Level_Kind; + In_Return_Context : Boolean := False; + Allow_Alt_Model : Boolean := True) return Node_Id; + -- Centralized accessibility level calculation routine for finding the + -- accessibility level of a given expression Expr. + + -- In_Return_Context forces the Accessibility_Level calculations to be + -- carried out "as if" Expr existed in a return value. This is useful for + -- calculating the accessibility levels for discriminant associations + -- and return aggregates. + + -- The Allow_Alt_Model parameter allows the alternative level calculation + -- under the restriction No_Dynamic_Accessibility_Checks to be performed. + + procedure Apply_Accessibility_Check + (N : Node_Id; + Typ : Entity_Id; + Insert_Node : Node_Id); + -- Given a name N denoting an access parameter, emits a run-time + -- accessibility check (if necessary), checking that the level of + -- the object denoted by the access parameter is not deeper than the + -- level of the type Typ. Program_Error is raised if the check fails. + -- Insert_Node indicates the node where the check should be inserted. + + procedure Apply_Accessibility_Check_For_Allocator + (N : Node_Id; + Exp : Node_Id; + Ref : Node_Id; + Built_In_Place : Boolean := False); + -- Ada 2005 (AI-344): For an allocator with a class-wide designated + -- type, generate an accessibility check to verify that the level of the + -- type of the created object is not deeper than the level of the access + -- type. If the type of the qualified expression is class-wide, then + -- always generate the check (except in the case where it is known to be + -- unnecessary, see comment below). Otherwise, only generate the check + -- if the level of the qualified expression type is statically deeper + -- than the access type. + -- + -- Although the static accessibility will generally have been performed + -- as a legality check, it won't have been done in cases where the + -- allocator appears in generic body, so a run-time check is needed in + -- general. One special case is when the access type is declared in the + -- same scope as the class-wide allocator, in which case the check can + -- never fail, so it need not be generated. + -- + -- As an open issue, there seem to be cases where the static level + -- associated with the class-wide object's underlying type is not + -- sufficient to perform the proper accessibility check, such as for + -- allocators in nested subprograms or accept statements initialized by + -- class-wide formals when the actual originates outside at a deeper + -- static level. The nested subprogram case might require passing + -- accessibility levels along with class-wide parameters, and the task + -- case seems to be an actual gap in the language rules that needs to + -- be fixed by the ARG. ??? + + procedure Check_Return_Construct_Accessibility + (Return_Stmt : Node_Id; + Stm_Entity : Entity_Id); + -- Apply legality rule of 6.5 (5.9) to the access discriminants of an + -- aggregate in a return statement. + + function Deepest_Type_Access_Level + (Typ : Entity_Id; + Allow_Alt_Model : Boolean := True) return Uint; + -- Same as Type_Access_Level, except that if the type is the type of an Ada + -- 2012 stand-alone object of an anonymous access type, then return the + -- static accessibility level of the object. In that case, the dynamic + -- accessibility level of the object may take on values in a range. The low + -- bound of that range is returned by Type_Access_Level; this function + -- yields the high bound of that range. Also differs from Type_Access_Level + -- in the case of a descendant of a generic formal type (returns Int'Last + -- instead of 0). + + -- The Allow_Alt_Model parameter allows the alternative level calculation + -- under the restriction No_Dynamic_Accessibility_Checks to be performed. + + function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id; + -- Same as Einfo.Extra_Accessibility except thtat object renames + -- are looked through. + + function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id; + -- Obtain the accessibility level for a given entity formal taking into + -- account both extra and minimum accessibility. + + function Has_Access_Values (T : Entity_Id) return Boolean; + -- Returns true if the underlying type of T is an access type, or has a + -- component (at any recursive level) that is an access type. This is a + -- conservative predicate, if it is not known whether or not T contains + -- access values (happens for generic formals in some cases), then False is + -- returned. Note that tagged types return False. Even though the tag is + -- implemented as an access type internally, this function tests only for + -- access types known to the programmer. See also Has_Tagged_Component. + + function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean; + -- Returns True if Typ has one or more anonymous access discriminants + + function Prefix_With_Safe_Accessibility_Level + (N : Node_Id; + Typ : Entity_Id) return Boolean; + -- Return True if the prefix does not have a value conversion of an + -- array because a value conversion is like an aggregate with respect + -- to determining accessibility level (RM 3.10.2); even if evaluation + -- of a value conversion is guaranteed to not create a new object, + -- accessibility rules are defined as if it might. + + subtype Static_Accessibility_Level_Kind + is Accessibility_Level_Kind range Object_Decl_Level + .. Zero_On_Dynamic_Level; + -- Restrict the reange of Accessibility_Level_Kind to be non-dynamic for + -- use in the static version of Accessibility_Level below. + + function Static_Accessibility_Level + (Expr : Node_Id; + Level : Static_Accessibility_Level_Kind; + In_Return_Context : Boolean := False) return Uint; + -- Overloaded version of Accessibility_Level which returns a universal + -- integer for use in compile-time checking. Note: Level is restricted to + -- be non-dynamic. + + function Has_Unconstrained_Access_Discriminants + (Subtyp : Entity_Id) return Boolean; + -- Returns True if the given subtype is unconstrained and has one or more + -- access discriminants. + + function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean; + -- Determine if N is used as an actual for a call whose corresponding + -- formal is of an anonymous access type. + + function Is_Special_Aliased_Formal_Access + (Exp : Node_Id; + In_Return_Context : Boolean := False) return Boolean; + -- Determines whether a dynamic check must be generated for explicitly + -- aliased formals within a function Scop for the expression Exp. + + -- In_Return_Context forces Is_Special_Aliased_Formal_Access to assume + -- that Exp is within a return value which is useful for checking + -- expressions within discriminant associations of return objects. + + -- More specially, Is_Special_Aliased_Formal_Access checks that Exp is a + -- 'Access attribute reference within a return statement where the ultimate + -- prefix is an aliased formal of Scop and that Scop returns an anonymous + -- access type. See RM 3.10.2 for more details. + + function Needs_Result_Accessibility_Level + (Func_Id : Entity_Id) return Boolean; + -- Ada 2012 (AI05-0234): Return True if the function needs an implicit + -- parameter to identify the accessibility level of the function result + -- "determined by the point of call". + + function Subprogram_Access_Level (Subp : Entity_Id) return Uint; + -- Return the accessibility level of the view denoted by Subp + + function Type_Access_Level + (Typ : Entity_Id; + Allow_Alt_Model : Boolean := True; + Assoc_Ent : Entity_Id := Empty) return Uint; + -- Return the accessibility level of Typ + + -- The Allow_Alt_Model parameter allows the alternative level calculation + -- under the restriction No_Dynamic_Accessibility_Checks to be performed. + + -- Assoc_Ent allows for the optional specification of the entity associated + -- with Typ. This gets utilized mostly for anonymous access type + -- processing, where context matters in interpreting Typ's level. + +end Accessibility; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 2a45f4d..5833be3 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -570,119 +570,6 @@ package body Checks is Install_Null_Excluding_Check (P); end Apply_Access_Check; - ------------------------------- - -- Apply_Accessibility_Check -- - ------------------------------- - - procedure Apply_Accessibility_Check - (N : Node_Id; - Typ : Entity_Id; - Insert_Node : Node_Id) - is - Loc : constant Source_Ptr := Sloc (N); - - Check_Cond : Node_Id; - Param_Ent : Entity_Id := Param_Entity (N); - Param_Level : Node_Id; - Type_Level : Node_Id; - - begin - -- Verify we haven't tried to add a dynamic accessibility check when we - -- shouldn't. - - pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N)); - - if Ada_Version >= Ada_2012 - and then No (Param_Ent) - and then Is_Entity_Name (N) - and then Ekind (Entity (N)) in E_Constant | E_Variable - and then Present (Effective_Extra_Accessibility (Entity (N))) - then - Param_Ent := Entity (N); - while Present (Renamed_Object (Param_Ent)) loop - -- Renamed_Object must return an Entity_Name here - -- because of preceding "Present (E_E_A (...))" test. - - Param_Ent := Entity (Renamed_Object (Param_Ent)); - end loop; - end if; - - if Inside_A_Generic then - return; - - -- Only apply the run-time check if the access parameter has an - -- associated extra access level parameter and when accessibility checks - -- are enabled. - - elsif Present (Param_Ent) - and then Present (Get_Dynamic_Accessibility (Param_Ent)) - and then not Accessibility_Checks_Suppressed (Param_Ent) - and then not Accessibility_Checks_Suppressed (Typ) - then - -- Obtain the parameter's accessibility level - - Param_Level := - New_Occurrence_Of (Get_Dynamic_Accessibility (Param_Ent), Loc); - - -- Use the dynamic accessibility parameter for the function's result - -- when one has been created instead of statically referring to the - -- deepest type level so as to appropriatly handle the rules for - -- RM 3.10.2 (10.1/3). - - if Ekind (Scope (Param_Ent)) = E_Function - and then In_Return_Value (N) - and then Ekind (Typ) = E_Anonymous_Access_Type - then - -- Associate the level of the result type to the extra result - -- accessibility parameter belonging to the current function. - - if Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then - Type_Level := - New_Occurrence_Of - (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc); - - -- In Ada 2005 and earlier modes, a result extra accessibility - -- parameter is not generated and no dynamic check is performed. - - else - return; - end if; - - -- Otherwise get the type's accessibility level normally - - else - Type_Level := - Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ)); - end if; - - -- Raise Program_Error if the accessibility level of the access - -- parameter is deeper than the level of the target access type. - - Check_Cond := - Make_Op_Gt (Loc, - Left_Opnd => Param_Level, - Right_Opnd => Type_Level); - - Insert_Action (Insert_Node, - Make_Raise_Program_Error (Loc, - Condition => Check_Cond, - Reason => PE_Accessibility_Check_Failed)); - - Analyze_And_Resolve (N); - - -- If constant folding has happened on the condition for the - -- generated error, then warn about it being unconditional. - - if Nkind (Check_Cond) = N_Identifier - and then Entity (Check_Cond) = Standard_True - then - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_N ("accessibility check fails<<", N); - Error_Msg_N ("\Program_Error [<<", N); - end if; - end if; - end Apply_Accessibility_Check; - -------------------------------- -- Apply_Address_Clause_Check -- -------------------------------- diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index a7d05a3..772adf0 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -189,16 +189,6 @@ package Checks is -- Determines whether an expression node requires a run-time access -- check and if so inserts the appropriate run-time check. - procedure Apply_Accessibility_Check - (N : Node_Id; - Typ : Entity_Id; - Insert_Node : Node_Id); - -- Given a name N denoting an access parameter, emits a run-time - -- accessibility check (if necessary), checking that the level of - -- the object denoted by the access parameter is not deeper than the - -- level of the type Typ. Program_Error is raised if the check fails. - -- Insert_Node indicates the node where the check should be inserted. - procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id); -- E is the entity for an object which has an address clause. If checks -- are enabled, then this procedure generates a check that the specified diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 9c8d80f..b7554e0 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; @@ -2215,13 +2216,25 @@ package body Exp_Attr is -- Local declarations - Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object); + Enc_Object : Node_Id := Enclosing_Object (Ref_Object); -- Start of processing for Access_Cases begin Btyp_DDT := Designated_Type (Btyp); + -- When Enc_Object is a view conversion then RM 3.10.2 (9) + -- applies and we obtain the expression being converted. + -- Otherwise we do not dig any deeper since a conversion + -- might generate a copy and we can't assume it will be as + -- long-lived as the original. + + while Nkind (Enc_Object) = N_Type_Conversion + and then Is_View_Conversion (Enc_Object) + loop + Enc_Object := Expression (Enc_Object); + end loop; + -- Handle designated types that come from the limited view if From_Limited_With (Btyp_DDT) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 2661a3f..5050ec6 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0a104cd..00d19e7 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; @@ -33,7 +34,6 @@ with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; -with Exp_Atag; use Exp_Atag; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; @@ -560,219 +560,6 @@ package body Exp_Ch4 is PtrT : constant Entity_Id := Etype (N); DesigT : constant Entity_Id := Designated_Type (PtrT); - procedure Apply_Accessibility_Check - (Ref : Node_Id; - Built_In_Place : Boolean := False); - -- Ada 2005 (AI-344): For an allocator with a class-wide designated - -- type, generate an accessibility check to verify that the level of the - -- type of the created object is not deeper than the level of the access - -- type. If the type of the qualified expression is class-wide, then - -- always generate the check (except in the case where it is known to be - -- unnecessary, see comment below). Otherwise, only generate the check - -- if the level of the qualified expression type is statically deeper - -- than the access type. - -- - -- Although the static accessibility will generally have been performed - -- as a legality check, it won't have been done in cases where the - -- allocator appears in generic body, so a run-time check is needed in - -- general. One special case is when the access type is declared in the - -- same scope as the class-wide allocator, in which case the check can - -- never fail, so it need not be generated. - -- - -- As an open issue, there seem to be cases where the static level - -- associated with the class-wide object's underlying type is not - -- sufficient to perform the proper accessibility check, such as for - -- allocators in nested subprograms or accept statements initialized by - -- class-wide formals when the actual originates outside at a deeper - -- static level. The nested subprogram case might require passing - -- accessibility levels along with class-wide parameters, and the task - -- case seems to be an actual gap in the language rules that needs to - -- be fixed by the ARG. ??? - - ------------------------------- - -- Apply_Accessibility_Check -- - ------------------------------- - - procedure Apply_Accessibility_Check - (Ref : Node_Id; - Built_In_Place : Boolean := False) - is - Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT); - Cond : Node_Id; - Fin_Call : Node_Id; - Free_Stmt : Node_Id; - Obj_Ref : Node_Id; - Stmts : List_Id; - - begin - if Ada_Version >= Ada_2005 - and then Is_Class_Wide_Type (DesigT) - and then Tagged_Type_Expansion - and then not Scope_Suppress.Suppress (Accessibility_Check) - and then not No_Dynamic_Accessibility_Checks_Enabled (Ref) - and then - (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT) - or else - (Is_Class_Wide_Type (Etype (Exp)) - and then Scope (PtrT) /= Current_Scope)) - then - -- If the allocator was built in place, Ref is already a reference - -- to the access object initialized to the result of the allocator - -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call - -- Remove_Side_Effects for cases where the build-in-place call may - -- still be the prefix of the reference (to avoid generating - -- duplicate calls). Otherwise, it is the entity associated with - -- the object containing the address of the allocated object. - - if Built_In_Place then - Remove_Side_Effects (Ref); - Obj_Ref := New_Copy_Tree (Ref); - else - Obj_Ref := New_Occurrence_Of (Ref, Loc); - end if; - - -- For access to interface types we must generate code to displace - -- the pointer to the base of the object since the subsequent code - -- references components located in the TSD of the object (which - -- is associated with the primary dispatch table --see a-tags.ads) - -- and also generates code invoking Free, which requires also a - -- reference to the base of the unallocated object. - - if Is_Interface (DesigT) and then Tagged_Type_Expansion then - Obj_Ref := - Unchecked_Convert_To (Etype (Obj_Ref), - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Base_Address), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Address), - New_Copy_Tree (Obj_Ref))))); - end if; - - -- Step 1: Create the object clean up code - - Stmts := New_List; - - -- Deallocate the object if the accessibility check fails. This - -- is done only on targets or profiles that support deallocation. - - -- Free (Obj_Ref); - - if RTE_Available (RE_Free) then - Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref)); - Set_Storage_Pool (Free_Stmt, Pool_Id); - - Append_To (Stmts, Free_Stmt); - - -- The target or profile cannot deallocate objects - - else - Free_Stmt := Empty; - end if; - - -- Finalize the object if applicable. Generate: - - -- [Deep_]Finalize (Obj_Ref.all); - - if Needs_Finalization (DesigT) - and then not No_Heap_Finalization (PtrT) - then - Fin_Call := - Make_Final_Call - (Obj_Ref => - Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)), - Typ => DesigT); - - -- Guard against a missing [Deep_]Finalize when the designated - -- type was not properly frozen. - - if No (Fin_Call) then - Fin_Call := Make_Null_Statement (Loc); - end if; - - -- When the target or profile supports deallocation, wrap the - -- finalization call in a block to ensure proper deallocation - -- even if finalization fails. Generate: - - -- begin - -- <Fin_Call> - -- exception - -- when others => - -- <Free_Stmt> - -- raise; - -- end; - - if Present (Free_Stmt) then - Fin_Call := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Fin_Call), - - Exception_Handlers => New_List ( - Make_Exception_Handler (Loc, - Exception_Choices => New_List ( - Make_Others_Choice (Loc)), - Statements => New_List ( - New_Copy_Tree (Free_Stmt), - Make_Raise_Statement (Loc)))))); - end if; - - Prepend_To (Stmts, Fin_Call); - end if; - - -- Signal the accessibility failure through a Program_Error - - Append_To (Stmts, - Make_Raise_Program_Error (Loc, - Reason => PE_Accessibility_Check_Failed)); - - -- Step 2: Create the accessibility comparison - - -- Generate: - -- Ref'Tag - - Obj_Ref := - Make_Attribute_Reference (Loc, - Prefix => Obj_Ref, - Attribute_Name => Name_Tag); - - -- For tagged types, determine the accessibility level by looking - -- at the type specific data of the dispatch table. Generate: - - -- Type_Specific_Data (Address (Ref'Tag)).Access_Level - - if Tagged_Type_Expansion then - Cond := Build_Get_Access_Level (Loc, Obj_Ref); - - -- Use a runtime call to determine the accessibility level when - -- compiling on virtual machine targets. Generate: - - -- Get_Access_Level (Ref'Tag) - - else - Cond := - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc), - Parameter_Associations => New_List (Obj_Ref)); - end if; - - Cond := - Make_Op_Gt (Loc, - Left_Opnd => Cond, - Right_Opnd => Accessibility_Level (N, Dynamic_Level)); - - -- Due to the complexity and side effects of the check, utilize an - -- if statement instead of the regular Program_Error circuitry. - - Insert_Action (N, - Make_Implicit_If_Statement (N, - Condition => Cond, - Then_Statements => Stmts)); - end if; - end Apply_Accessibility_Check; - -- Local variables Indic : constant Node_Id := Subtype_Mark (Expression (N)); @@ -884,7 +671,8 @@ package body Exp_Ch4 is if Is_Build_In_Place_Function_Call (Exp) then Make_Build_In_Place_Call_In_Allocator (N, Exp); - Apply_Accessibility_Check (N, Built_In_Place => True); + Apply_Accessibility_Check_For_Allocator + (N, Exp, N, Built_In_Place => True); return; -- Ada 2005 (AI-318-02): Specialization of the previous case for @@ -896,7 +684,8 @@ package body Exp_Ch4 is elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp); - Apply_Accessibility_Check (N, Built_In_Place => True); + Apply_Accessibility_Check_For_Allocator + (N, Exp, N, Built_In_Place => True); return; end if; @@ -1191,7 +980,7 @@ package body Exp_Ch4 is -- Note: the accessibility check must be inserted after the call to -- [Deep_]Adjust to ensure proper completion of the assignment. - Apply_Accessibility_Check (Temp); + Apply_Accessibility_Check_For_Allocator (N, Exp, Temp); Rewrite (N, New_Occurrence_Of (Temp, Loc)); Analyze_And_Resolve (N, PtrT); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 3ea6cbb..d67f788 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 0fe980c..ae59ad7 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Atree; use Atree; with Aspects; use Aspects; with Checks; use Checks; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 70ede15..7d76144 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Atree; use Atree; with Aspects; use Aspects; with Checks; use Checks; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 41da7a2..e0ad27e 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 45a4168..2acd195 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -399,6 +399,7 @@ GNAT_ADA_OBJS = \ ada/sem_ch12.o \ ada/sem_ch13.o \ ada/sem_ch2.o \ + ada/accessibility.o \ ada/sem_ch3.o \ ada/sem_ch4.o \ ada/sem_ch5.o \ diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 83c7180..e0dba9e 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -98,6 +98,7 @@ package Gen_IL.Fields is Cleanup_Actions, Comes_From_Check_Or_Contract, Comes_From_Extended_Return_Statement, + Comes_From_Iterator, Compile_Time_Known_Aggregate, Component_Associations, Component_Clauses, diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 556326a..ba45391 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -906,6 +906,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Subtype_Mark, Node_Id, Default_Empty), Sy (Access_Definition, Node_Id, Default_Empty), Sy (Name, Node_Id, Default_Empty), + Sm (Comes_From_Iterator, Flag), Sm (Corresponding_Generic_Association, Node_Id))); Cc (N_Package_Renaming_Declaration, N_Renaming_Declaration, diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 3e978f9..433f1ac 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -3242,7 +3242,7 @@ package body Sem_Aggr is end loop; end; - else + elsif Present (Assign_Indexed_Subp) then -- Indexed Aggregate. Positional or indexed component -- can be present, but not both. Choices must be static -- values or ranges with static bounds. diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index cca6f6f..7c76f0f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -25,6 +25,7 @@ with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Casing; use Casing; @@ -10936,72 +10937,12 @@ package body Sem_Attr is It : Interp; Nom_Subt : Entity_Id; - procedure Accessibility_Message; - -- Error, or warning within an instance, if the static accessibility - -- rules of 3.10.2 are violated. - function Declared_Within_Generic_Unit (Entity : Entity_Id; Generic_Unit : Node_Id) return Boolean; -- Returns True if Declared_Entity is declared within the declarative -- region of Generic_Unit; otherwise returns False. - function Prefix_With_Safe_Accessibility_Level return Boolean; - -- Return True if the prefix does not have a value conversion of an - -- array because a value conversion is like an aggregate with respect - -- to determining accessibility level (RM 3.10.2); even if evaluation - -- of a value conversion is guaranteed to not create a new object, - -- accessibility rules are defined as if it might. - - --------------------------- - -- Accessibility_Message -- - --------------------------- - - procedure Accessibility_Message is - Indic : Node_Id := Parent (Parent (N)); - - begin - -- In an instance, this is a runtime check, but one we - -- know will fail, so generate an appropriate warning. - - if In_Instance_Body then - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_F - ("non-local pointer cannot point to local object<<", P); - Error_Msg_F ("\Program_Error [<<", P); - Rewrite (N, - Make_Raise_Program_Error (Loc, - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Typ); - return; - - else - Error_Msg_F ("non-local pointer cannot point to local object", P); - - -- Check for case where we have a missing access definition - - if Is_Record_Type (Current_Scope) - and then - Nkind (Parent (N)) in N_Discriminant_Association - | N_Index_Or_Discriminant_Constraint - then - Indic := Parent (Parent (N)); - while Present (Indic) - and then Nkind (Indic) /= N_Subtype_Indication - loop - Indic := Parent (Indic); - end loop; - - if Present (Indic) then - Error_Msg_NE - ("\use an access definition for" & - " the access discriminant of&", - N, Entity (Subtype_Mark (Indic))); - end if; - end if; - end if; - end Accessibility_Message; - ---------------------------------- -- Declared_Within_Generic_Unit -- ---------------------------------- @@ -11029,70 +10970,6 @@ package body Sem_Attr is return False; end Declared_Within_Generic_Unit; - ------------------------------------------ - -- Prefix_With_Safe_Accessibility_Level -- - ------------------------------------------ - - function Prefix_With_Safe_Accessibility_Level return Boolean is - function Safe_Value_Conversions return Boolean; - -- Return False if the prefix has a value conversion of an array type - - ---------------------------- - -- Safe_Value_Conversions -- - ---------------------------- - - function Safe_Value_Conversions return Boolean is - PP : Node_Id := P; - - begin - loop - if Nkind (PP) in N_Selected_Component | N_Indexed_Component then - PP := Prefix (PP); - - elsif Comes_From_Source (PP) - and then Nkind (PP) in N_Type_Conversion - | N_Unchecked_Type_Conversion - and then Is_Array_Type (Etype (PP)) - then - return False; - - elsif Comes_From_Source (PP) - and then Nkind (PP) = N_Qualified_Expression - and then Is_Array_Type (Etype (PP)) - and then Nkind (Original_Node (Expression (PP))) in - N_Aggregate | N_Extension_Aggregate - then - return False; - - else - exit; - end if; - end loop; - - return True; - end Safe_Value_Conversions; - - -- Start of processing for Prefix_With_Safe_Accessibility_Level - - begin - -- No check required for unchecked and unrestricted access - - if Attr_Id = Attribute_Unchecked_Access - or else Attr_Id = Attribute_Unrestricted_Access - then - return True; - - -- Check value conversions - - elsif Ekind (Btyp) = E_General_Access_Type - and then not Safe_Value_Conversions - then - return False; - end if; - - return True; - end Prefix_With_Safe_Accessibility_Level; - -- Start of processing for Resolve_Attribute begin @@ -11778,7 +11655,7 @@ package body Sem_Attr is Intval (Accessibility_Level (P, Dynamic_Level)) > Deepest_Type_Access_Level (Btyp) then - Accessibility_Message; + Accessibility_Message (N, Typ); return; end if; end; @@ -11804,7 +11681,7 @@ package body Sem_Attr is and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type and then Attr_Id /= Attribute_Unrestricted_Access then - Accessibility_Message; + Accessibility_Message (N, Typ); return; -- AI05-0225: If the context is not an access to protected @@ -11963,8 +11840,8 @@ package body Sem_Attr is -- array type since a value conversion is like an aggregate with -- respect to determining accessibility level (RM 3.10.2). - if not Prefix_With_Safe_Accessibility_Level then - Accessibility_Message; + if not Prefix_With_Safe_Accessibility_Level (N, Typ) then + Accessibility_Message (N, Typ); return; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 71eabb4..618f935 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 61386e2..abee91f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index b724fbe..c8c0d80 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Debug; use Debug; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index b54f270..c1523ae 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2523,6 +2523,7 @@ package body Sem_Ch5 is Subtype_Mark => New_Occurrence_Of (Typ, Loc), Name => New_Copy_Tree (Iter_Name, New_Sloc => Loc)); + Set_Comes_From_Iterator (Decl); Insert_Actions (Parent (Parent (N)), New_List (Decl)); Rewrite (Name (N), New_Occurrence_Of (Id, Loc)); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index cb982b3..d567f79 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; @@ -745,10 +746,6 @@ package body Sem_Ch6 is -- Ada 2022: Check that the return expression in a No_Return function -- meets the conditions specified by RM 6.5.1(5.1/5). - procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id); - -- Apply legality rule of 6.5 (5.9) to the access discriminants of an - -- aggregate in a return statement. - procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id); -- Check that the return_subtype_indication properly matches the result -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2). @@ -781,516 +778,6 @@ package body Sem_Ch6 is Return_Expr); end Check_No_Return_Expression; - ------------------------------------------ - -- Check_Return_Construct_Accessibility -- - ------------------------------------------ - - procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is - - function First_Selector (Assoc : Node_Id) return Node_Id; - -- Obtain the first selector or choice from a given association - - function Is_Formal_Of_Current_Function - (Assoc_Expr : Entity_Id) return Boolean; - -- Predicate to test if a given expression associated with a - -- discriminant is a formal parameter to the function in which the - -- return construct we checking applies to. - - -------------------- - -- First_Selector -- - -------------------- - - function First_Selector (Assoc : Node_Id) return Node_Id is - begin - if Nkind (Assoc) = N_Component_Association then - return First (Choices (Assoc)); - - elsif Nkind (Assoc) = N_Discriminant_Association then - return (First (Selector_Names (Assoc))); - - else - raise Program_Error; - end if; - end First_Selector; - - ----------------------------------- - -- Is_Formal_Of_Current_Function -- - ----------------------------------- - - function Is_Formal_Of_Current_Function - (Assoc_Expr : Entity_Id) return Boolean is - begin - return Is_Entity_Name (Assoc_Expr) - and then Enclosing_Subprogram - (Entity (Assoc_Expr)) = Scope_Id - and then Is_Formal (Entity (Assoc_Expr)); - end Is_Formal_Of_Current_Function; - - -- Local declarations - - Assoc : Node_Id := Empty; - -- Assoc should perhaps be renamed and declared as a - -- Node_Or_Entity_Id since it encompasses not only component and - -- discriminant associations, but also discriminant components within - -- a type declaration or subtype indication ??? - - Assoc_Expr : Node_Id; - Assoc_Present : Boolean := False; - - Check_Cond : Node_Id; - Unseen_Disc_Count : Nat := 0; - Seen_Discs : Elist_Id; - Disc : Entity_Id; - First_Disc : Entity_Id; - - Obj_Decl : Node_Id; - Return_Con : Node_Id; - Unqual : Node_Id; - - -- Start of processing for Check_Return_Construct_Accessibility - - begin - -- Only perform checks on record types with access discriminants and - -- non-internally generated functions. - - if not Is_Record_Type (R_Type) - or else not Has_Anonymous_Access_Discriminant (R_Type) - or else not Comes_From_Source (Return_Stmt) - then - return; - end if; - - -- We are only interested in return statements - - if Nkind (Return_Stmt) not in - N_Extended_Return_Statement | N_Simple_Return_Statement - then - return; - end if; - - -- Fetch the object from the return statement, in the case of a - -- simple return statement the expression is part of the node. - - if Nkind (Return_Stmt) = N_Extended_Return_Statement then - -- Obtain the object definition from the expanded extended return - - Return_Con := First (Return_Object_Declarations (Return_Stmt)); - while Present (Return_Con) loop - -- Inspect the original node to avoid object declarations - -- expanded into renamings. - - if Nkind (Original_Node (Return_Con)) = N_Object_Declaration - and then Comes_From_Source (Original_Node (Return_Con)) - then - exit; - end if; - - Nlists.Next (Return_Con); - end loop; - - pragma Assert (Present (Return_Con)); - - -- Could be dealing with a renaming - - Return_Con := Original_Node (Return_Con); - else - Return_Con := Expression (Return_Stmt); - end if; - - -- Obtain the accessibility levels of the expressions associated - -- with all anonymous access discriminants, then generate a - -- dynamic check or static error when relevant. - - -- Note the repeated use of Original_Node to avoid checking - -- expanded code. - - Unqual := Original_Node (Unqualify (Original_Node (Return_Con))); - - -- Get the corresponding declaration based on the return object's - -- identifier. - - if Nkind (Unqual) = N_Identifier - and then Nkind (Parent (Entity (Unqual))) - in N_Object_Declaration - | N_Object_Renaming_Declaration - then - Obj_Decl := Original_Node (Parent (Entity (Unqual))); - - -- We were passed the object declaration directly, so use it - - elsif Nkind (Unqual) in N_Object_Declaration - | N_Object_Renaming_Declaration - then - Obj_Decl := Unqual; - - -- Otherwise, we are looking at something else - - else - Obj_Decl := Empty; - - end if; - - -- Hop up object renamings when present - - if Present (Obj_Decl) - and then Nkind (Obj_Decl) = N_Object_Renaming_Declaration - then - while Nkind (Obj_Decl) = N_Object_Renaming_Declaration loop - - if Nkind (Name (Obj_Decl)) not in N_Entity then - -- We may be looking at the expansion of iterators or - -- some other internally generated construct, so it is safe - -- to ignore checks ??? - - if not Comes_From_Source (Obj_Decl) then - return; - end if; - - Obj_Decl := Original_Node - (Declaration_Node - (Ultimate_Prefix (Name (Obj_Decl)))); - - -- Move up to the next declaration based on the object's name - - else - Obj_Decl := Original_Node - (Declaration_Node (Name (Obj_Decl))); - end if; - end loop; - end if; - - -- Obtain the discriminant values from the return aggregate - - -- Do we cover extension aggregates correctly ??? - - if Nkind (Unqual) = N_Aggregate then - if Present (Expressions (Unqual)) then - Assoc := First (Expressions (Unqual)); - else - Assoc := First (Component_Associations (Unqual)); - end if; - - -- There is an object declaration for the return object - - elsif Present (Obj_Decl) then - -- When a subtype indication is present in an object declaration - -- it must contain the object's discriminants. - - if Nkind (Object_Definition (Obj_Decl)) = N_Subtype_Indication then - Assoc := First - (Constraints - (Constraint - (Object_Definition (Obj_Decl)))); - - -- The object declaration contains an aggregate - - elsif Present (Expression (Obj_Decl)) then - - if Nkind (Unqualify (Expression (Obj_Decl))) = N_Aggregate then - -- Grab the first associated discriminant expresion - - if Present - (Expressions (Unqualify (Expression (Obj_Decl)))) - then - Assoc := First - (Expressions - (Unqualify (Expression (Obj_Decl)))); - else - Assoc := First - (Component_Associations - (Unqualify (Expression (Obj_Decl)))); - end if; - - -- Otherwise, this is something else - - else - return; - end if; - - -- There are no supplied discriminants in the object declaration, - -- so get them from the type definition since they must be default - -- initialized. - - -- Do we handle constrained subtypes correctly ??? - - elsif Nkind (Unqual) = N_Object_Declaration then - Assoc := First_Discriminant - (Etype (Object_Definition (Obj_Decl))); - - else - Assoc := First_Discriminant (Etype (Unqual)); - end if; - - -- When we are not looking at an aggregate or an identifier, return - -- since any other construct (like a function call) is not - -- applicable since checks will be performed on the side of the - -- callee. - - else - return; - end if; - - -- Obtain the discriminants so we know the actual type in case the - -- value of their associated expression gets implicitly converted. - - if No (Obj_Decl) then - pragma Assert (Nkind (Unqual) = N_Aggregate); - - Disc := First_Discriminant (Etype (Unqual)); - - else - Disc := First_Discriminant - (Etype (Defining_Identifier (Obj_Decl))); - end if; - - -- Preserve the first discriminant for checking named associations - - First_Disc := Disc; - - -- Count the number of discriminants for processing an aggregate - -- which includes an others. - - Disc := First_Disc; - while Present (Disc) loop - Unseen_Disc_Count := Unseen_Disc_Count + 1; - - Next_Discriminant (Disc); - end loop; - - Seen_Discs := New_Elmt_List; - - -- Loop through each of the discriminants and check each expression - -- associated with an anonymous access discriminant. - - -- When named associations occur in the return aggregate then - -- discriminants can be in any order, so we need to ensure we do - -- not continue to loop when all discriminants have been seen. - - Disc := First_Disc; - while Present (Assoc) - and then (Present (Disc) or else Assoc_Present) - and then Unseen_Disc_Count > 0 - loop - -- Handle named associations by searching through the names of - -- the relevant discriminant components. - - if Nkind (Assoc) - in N_Component_Association | N_Discriminant_Association - then - Assoc_Expr := Expression (Assoc); - Assoc_Present := True; - - -- We currently don't handle box initialized discriminants, - -- however, since default initialized anonymous access - -- discriminants are a corner case, this is ok for now ??? - - if Nkind (Assoc) = N_Component_Association - and then Box_Present (Assoc) - then - if Nkind (First_Selector (Assoc)) = N_Others_Choice then - Unseen_Disc_Count := 0; - end if; - - -- When others is present we must identify a discriminant we - -- haven't already seen so as to get the appropriate type for - -- the static accessibility check. - - -- This works because all components within an others clause - -- must have the same type. - - elsif Nkind (First_Selector (Assoc)) = N_Others_Choice then - - Disc := First_Disc; - Outer : while Present (Disc) loop - declare - Current_Seen_Disc : Elmt_Id; - begin - -- Move through the list of identified discriminants - - Current_Seen_Disc := First_Elmt (Seen_Discs); - while Present (Current_Seen_Disc) loop - -- Exit the loop when we found a match - - exit when - Chars (Node (Current_Seen_Disc)) = Chars (Disc); - - Next_Elmt (Current_Seen_Disc); - end loop; - - -- When we have exited the above loop without finding - -- a match then we know that Disc has not been seen. - - exit Outer when No (Current_Seen_Disc); - end; - - Next_Discriminant (Disc); - end loop Outer; - - -- If we got to an others clause with a non-zero - -- discriminant count there must be a discriminant left to - -- check. - - pragma Assert (Present (Disc)); - - -- Set the unseen discriminant count to zero because we know - -- an others clause sets all remaining components of an - -- aggregate. - - Unseen_Disc_Count := 0; - - -- Move through each of the selectors in the named association - -- and obtain a discriminant for accessibility checking if one - -- is referenced in the list. Also track which discriminants - -- are referenced for the purpose of handling an others clause. - - else - declare - Assoc_Choice : Node_Id; - Curr_Disc : Node_Id; - begin - - Disc := Empty; - Curr_Disc := First_Disc; - while Present (Curr_Disc) loop - -- Check each of the choices in the associations for a - -- match to the name of the current discriminant. - - Assoc_Choice := First_Selector (Assoc); - while Present (Assoc_Choice) loop - -- When the name matches we track that we have seen - -- the discriminant, but instead of exiting the - -- loop we continue iterating to make sure all the - -- discriminants within the named association get - -- tracked. - - if Chars (Assoc_Choice) = Chars (Curr_Disc) then - Append_Elmt (Curr_Disc, Seen_Discs); - - Disc := Curr_Disc; - Unseen_Disc_Count := Unseen_Disc_Count - 1; - end if; - - Next (Assoc_Choice); - end loop; - - Next_Discriminant (Curr_Disc); - end loop; - end; - end if; - - -- Unwrap the associated expression if we are looking at a default - -- initialized type declaration. In this case Assoc is not really - -- an association, but a component declaration. Should Assoc be - -- renamed in some way to be more clear ??? - - -- This occurs when the return object does not initialize - -- discriminant and instead relies on the type declaration for - -- their supplied values. - - elsif Nkind (Assoc) in N_Entity - and then Ekind (Assoc) = E_Discriminant - then - Append_Elmt (Disc, Seen_Discs); - - Assoc_Expr := Discriminant_Default_Value (Assoc); - Unseen_Disc_Count := Unseen_Disc_Count - 1; - - -- Otherwise, there is nothing to do because Assoc is an - -- expression within the return aggregate itself. - - else - Append_Elmt (Disc, Seen_Discs); - - Assoc_Expr := Assoc; - Unseen_Disc_Count := Unseen_Disc_Count - 1; - end if; - - -- Check the accessibility level of the expression when the - -- discriminant is of an anonymous access type. - - if Present (Assoc_Expr) - and then Present (Disc) - and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type - - -- We disable the check when we have a tagged return type and - -- the associated expression for the discriminant is a formal - -- parameter since the check would require us to compare the - -- accessibility level of Assoc_Expr to the level of the - -- Extra_Accessibility_Of_Result of the function - which is - -- currently disabled for functions with tagged return types. - -- This may change in the future ??? - - -- See Needs_Result_Accessibility_Level for details. - - and then not - (No (Extra_Accessibility_Of_Result (Scope_Id)) - and then Is_Formal_Of_Current_Function (Assoc_Expr) - and then Is_Tagged_Type (Etype (Scope_Id))) - then - -- Generate a dynamic check based on the extra accessibility of - -- the result or the scope of the current function. - - Check_Cond := - Make_Op_Gt (Loc, - Left_Opnd => Accessibility_Level - (Expr => Assoc_Expr, - Level => Dynamic_Level, - In_Return_Context => True), - Right_Opnd => - (if Present (Extra_Accessibility_Of_Result (Scope_Id)) - - -- When Assoc_Expr is a formal we have to look at the - -- extra accessibility-level formal associated with - -- the result. - - and then Is_Formal_Of_Current_Function (Assoc_Expr) - then - New_Occurrence_Of - (Extra_Accessibility_Of_Result (Scope_Id), Loc) - - -- Otherwise, we compare the level of Assoc_Expr to the - -- scope of the current function. - - else - Make_Integer_Literal - (Loc, Scope_Depth (Scope (Scope_Id))))); - - Insert_Before_And_Analyze (Return_Stmt, - Make_Raise_Program_Error (Loc, - Condition => Check_Cond, - Reason => PE_Accessibility_Check_Failed)); - - -- If constant folding has happened on the condition for the - -- generated error, then warn about it being unconditional when - -- we know an error will be raised. - - if Nkind (Check_Cond) = N_Identifier - and then Entity (Check_Cond) = Standard_True - then - Error_Msg_N - ("access discriminant in return object would be a dangling" - & " reference", Return_Stmt); - end if; - end if; - - -- Iterate over the discriminants, except when we have encountered - -- a named association since the discriminant order becomes - -- irrelevant in that case. - - if not Assoc_Present then - Next_Discriminant (Disc); - end if; - - -- Iterate over associations - - if not Is_List_Member (Assoc) then - exit; - else - Nlists.Next (Assoc); - end if; - end loop; - end Check_Return_Construct_Accessibility; - ------------------------------------- -- Check_Return_Subtype_Indication -- ------------------------------------- @@ -1495,7 +982,7 @@ package body Sem_Ch6 is Resolve (Expr, R_Type); Check_Limited_Return (N, Expr, R_Type); - Check_Return_Construct_Accessibility (N); + Check_Return_Construct_Accessibility (N, Stm_Entity); -- Ada 2022 (AI12-0269): Any return statement that applies to a -- nonreturning function shall be a simple_return_statement with @@ -1551,7 +1038,7 @@ package body Sem_Ch6 is Check_References (Stm_Entity); - Check_Return_Construct_Accessibility (N); + Check_Return_Construct_Accessibility (N, Stm_Entity); -- Check RM 6.5 (5.9/3) diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index e43e3ae..aad86fa 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index e702df6..70c7c7c 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a13d9eb..1fef847 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Casing; use Casing; with Checks; use Checks; with Debug; use Debug; @@ -30,7 +31,6 @@ with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; with Erroutc; use Erroutc; -with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; @@ -255,740 +255,6 @@ package body Sem_Util is return Interface_List (Nod); end Abstract_Interface_List; - ------------------------- - -- Accessibility_Level -- - ------------------------- - - function Accessibility_Level - (Expr : Node_Id; - Level : Accessibility_Level_Kind; - In_Return_Context : Boolean := False; - Allow_Alt_Model : Boolean := True) return Node_Id - is - Loc : constant Source_Ptr := Sloc (Expr); - - function Accessibility_Level (Expr : Node_Id) return Node_Id - is (Accessibility_Level (Expr, Level, In_Return_Context)); - -- Renaming of the enclosing function to facilitate recursive calls - - function Make_Level_Literal (Level : Uint) return Node_Id; - -- Construct an integer literal representing an accessibility level - -- with its type set to Natural. - - function Innermost_Master_Scope_Depth (N : Node_Id) return Uint; - -- Returns the scope depth of the given node's innermost enclosing - -- scope (effectively the accessibility level of the innermost - -- enclosing master). - - function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id; - -- Centralized processing of subprogram calls which may appear in - -- prefix notation. - - function Typ_Access_Level (Typ : Entity_Id) return Uint - is (Type_Access_Level (Typ, Allow_Alt_Model)); - -- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid - -- passing the parameter specifically in every call. - - ---------------------------------- - -- Innermost_Master_Scope_Depth -- - ---------------------------------- - - function Innermost_Master_Scope_Depth (N : Node_Id) return Uint is - Encl_Scop : Entity_Id; - Ent : Entity_Id; - Node_Par : Node_Id := Parent (N); - Master_Lvl_Modifier : Int := 0; - - begin - -- Locate the nearest enclosing node (by traversing Parents) - -- that Defining_Entity can be applied to, and return the - -- depth of that entity's nearest enclosing scope. - - -- The rules that define what a master are defined in - -- RM 7.6.1 (3), and include statements and conditions for loops - -- among other things. These cases are detected properly ??? - - while Present (Node_Par) loop - Ent := Defining_Entity_Or_Empty (Node_Par); - - if Present (Ent) then - Encl_Scop := Find_Enclosing_Scope (Ent); - - -- Ignore transient scopes made during expansion - - if Comes_From_Source (Node_Par) then - -- Note that in some rare cases the scope depth may not be - -- set, for example, when we are in the middle of analyzing - -- a type and the enclosing scope is said type. So, instead, - -- continue to move up the parent chain since the scope - -- depth of the type's parent is the same as that of the - -- type. - - if not Scope_Depth_Set (Encl_Scop) then - pragma Assert (Nkind (Parent (Encl_Scop)) - = N_Full_Type_Declaration); - else - return - Scope_Depth (Encl_Scop) + Master_Lvl_Modifier; - end if; - end if; - - -- For a return statement within a function, return - -- the depth of the function itself. This is not just - -- a small optimization, but matters when analyzing - -- the expression in an expression function before - -- the body is created. - - elsif Nkind (Node_Par) in N_Extended_Return_Statement - | N_Simple_Return_Statement - then - return Scope_Depth (Enclosing_Subprogram (Node_Par)); - - -- Statements are counted as masters - - elsif Is_Master (Node_Par) then - Master_Lvl_Modifier := Master_Lvl_Modifier + 1; - - end if; - - Node_Par := Parent (Node_Par); - end loop; - - -- Should never reach the following return - - pragma Assert (False); - - return Scope_Depth (Current_Scope) + 1; - end Innermost_Master_Scope_Depth; - - ------------------------ - -- Make_Level_Literal -- - ------------------------ - - function Make_Level_Literal (Level : Uint) return Node_Id is - Result : constant Node_Id := Make_Integer_Literal (Loc, Level); - - begin - Set_Etype (Result, Standard_Natural); - return Result; - end Make_Level_Literal; - - -------------------------------------- - -- Function_Call_Or_Allocator_Level -- - -------------------------------------- - - function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id is - Par : Node_Id; - Prev_Par : Node_Id; - begin - -- Results of functions are objects, so we either get the - -- accessibility of the function or, in case of a call which is - -- indirect, the level of the access-to-subprogram type. - - -- This code looks wrong ??? - - if Nkind (N) = N_Function_Call - and then Ada_Version < Ada_2005 - then - if Is_Entity_Name (Name (N)) then - return Make_Level_Literal - (Subprogram_Access_Level (Entity (Name (N)))); - else - return Make_Level_Literal - (Typ_Access_Level (Etype (Prefix (Name (N))))); - end if; - - -- We ignore coextensions as they cannot be implemented under the - -- "small-integer" model. - - elsif Nkind (N) = N_Allocator - and then (Is_Static_Coextension (N) - or else Is_Dynamic_Coextension (N)) - then - return Make_Level_Literal (Scope_Depth (Standard_Standard)); - end if; - - -- Named access types have a designated level - - if Is_Named_Access_Type (Etype (N)) then - return Make_Level_Literal (Typ_Access_Level (Etype (N))); - - -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3) - - else - -- Check No_Dynamic_Accessibility_Checks restriction override for - -- alternative accessibility model. - - if Allow_Alt_Model - and then No_Dynamic_Accessibility_Checks_Enabled (N) - and then Is_Anonymous_Access_Type (Etype (N)) - then - -- In the alternative model the level is that of the - -- designated type. - - if Debug_Flag_Underscore_B then - return Make_Level_Literal (Typ_Access_Level (Etype (N))); - - -- For function calls the level is that of the innermost - -- master, otherwise (for allocators etc.) we get the level - -- of the corresponding anonymous access type, which is - -- calculated through the normal path of execution. - - elsif Nkind (N) = N_Function_Call then - return Make_Level_Literal - (Innermost_Master_Scope_Depth (Expr)); - end if; - end if; - - if Nkind (N) = N_Function_Call then - -- Dynamic checks are generated when we are within a return - -- value or we are in a function call within an anonymous - -- access discriminant constraint of a return object (signified - -- by In_Return_Context) on the side of the callee. - - -- So, in this case, return accessibility level of the - -- enclosing subprogram. - - if In_Return_Value (N) - or else In_Return_Context - then - return Make_Level_Literal - (Subprogram_Access_Level (Current_Subprogram)); - end if; - end if; - - -- When the call is being dereferenced the level is that of the - -- enclosing master of the dereferenced call. - - if Nkind (Parent (N)) in N_Explicit_Dereference - | N_Indexed_Component - | N_Selected_Component - then - return Make_Level_Literal - (Innermost_Master_Scope_Depth (Expr)); - end if; - - -- Find any relevant enclosing parent nodes that designate an - -- object being initialized. - - -- Note: The above is only relevant if the result is used "in its - -- entirety" as RM 3.10.2 (10.2/3) states. However, this is - -- accounted for in the case statement in the main body of - -- Accessibility_Level for N_Selected_Component. - - Par := Parent (Expr); - Prev_Par := Empty; - while Present (Par) loop - -- Detect an expanded implicit conversion, typically this - -- occurs on implicitly converted actuals in calls. - - -- Does this catch all implicit conversions ??? - - if Nkind (Par) = N_Type_Conversion - and then Is_Named_Access_Type (Etype (Par)) - then - return Make_Level_Literal - (Typ_Access_Level (Etype (Par))); - end if; - - -- Jump out when we hit an object declaration or the right-hand - -- side of an assignment, or a construct such as an aggregate - -- subtype indication which would be the result is not used - -- "in its entirety." - - exit when Nkind (Par) in N_Object_Declaration - or else (Nkind (Par) = N_Assignment_Statement - and then Name (Par) /= Prev_Par); - - Prev_Par := Par; - Par := Parent (Par); - end loop; - - -- Assignment statements are handled in a similar way in - -- accordance to the left-hand part. However, strictly speaking, - -- this is illegal according to the RM, but this change is needed - -- to pass an ACATS C-test and is useful in general ??? - - case Nkind (Par) is - when N_Object_Declaration => - return Make_Level_Literal - (Scope_Depth - (Scope (Defining_Identifier (Par)))); - - when N_Assignment_Statement => - -- Return the accessibility level of the left-hand part - - return Accessibility_Level - (Expr => Name (Par), - Level => Object_Decl_Level, - In_Return_Context => In_Return_Context); - - when others => - return Make_Level_Literal - (Innermost_Master_Scope_Depth (Expr)); - end case; - end if; - end Function_Call_Or_Allocator_Level; - - -- Local variables - - E : Node_Id := Original_Node (Expr); - Pre : Node_Id; - - -- Start of processing for Accessibility_Level - - begin - -- We could be looking at a reference to a formal due to the expansion - -- of entries and other cases, so obtain the renaming if necessary. - - if Present (Param_Entity (Expr)) then - E := Param_Entity (Expr); - end if; - - -- Extract the entity - - if Nkind (E) in N_Has_Entity and then Present (Entity (E)) then - E := Entity (E); - - -- Deal with a possible renaming of a private protected component - - if Ekind (E) in E_Constant | E_Variable and then Is_Prival (E) then - E := Prival_Link (E); - end if; - end if; - - -- Perform the processing on the expression - - case Nkind (E) is - -- The level of an aggregate is that of the innermost master that - -- evaluates it as defined in RM 3.10.2 (10/4). - - when N_Aggregate => - return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr)); - - -- The accessibility level is that of the access type, except for an - -- anonymous allocators which have special rules defined in RM 3.10.2 - -- (14/3). - - when N_Allocator => - return Function_Call_Or_Allocator_Level (E); - - -- We could reach this point for two reasons. Either the expression - -- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or - -- we are looking at the access attributes directly ('Access, - -- 'Address, or 'Unchecked_Access). - - when N_Attribute_Reference => - Pre := Original_Node (Prefix (E)); - - -- Regular 'Access attribute presence means we have to look at the - -- prefix. - - if Attribute_Name (E) = Name_Access then - return Accessibility_Level (Prefix (E)); - - -- Unchecked or unrestricted attributes have unlimited depth - - elsif Attribute_Name (E) in Name_Address - | Name_Unchecked_Access - | Name_Unrestricted_Access - then - return Make_Level_Literal (Scope_Depth (Standard_Standard)); - - -- 'Access can be taken further against other special attributes, - -- so handle these cases explicitly. - - elsif Attribute_Name (E) - in Name_Old | Name_Loop_Entry | Name_Result - then - -- Named access types - - if Is_Named_Access_Type (Etype (Pre)) then - return Make_Level_Literal - (Typ_Access_Level (Etype (Pre))); - - -- Anonymous access types - - elsif Nkind (Pre) in N_Has_Entity - and then Ekind (Entity (Pre)) not in Subprogram_Kind - and then Present (Get_Dynamic_Accessibility (Entity (Pre))) - and then Level = Dynamic_Level - then - return New_Occurrence_Of - (Get_Dynamic_Accessibility (Entity (Pre)), Loc); - - -- Otherwise the level is treated in a similar way as - -- aggregates according to RM 6.1.1 (35.1/4) which concerns - -- an implicit constant declaration - in turn defining the - -- accessibility level to be that of the implicit constant - -- declaration. - - else - return Make_Level_Literal - (Innermost_Master_Scope_Depth (Expr)); - end if; - - else - raise Program_Error; - end if; - - -- This is the "base case" for accessibility level calculations which - -- means we are near the end of our recursive traversal. - - when N_Defining_Identifier => - -- A dynamic check is performed on the side of the callee when we - -- are within a return statement, so return a library-level - -- accessibility level to null out checks on the side of the - -- caller. - - if Is_Explicitly_Aliased (E) - and then (In_Return_Context - or else (Level /= Dynamic_Level - and then In_Return_Value (Expr))) - then - return Make_Level_Literal (Scope_Depth (Standard_Standard)); - - -- Something went wrong and an extra accessibility formal has not - -- been generated when one should have ??? - - elsif Is_Formal (E) - and then No (Get_Dynamic_Accessibility (E)) - and then Ekind (Etype (E)) = E_Anonymous_Access_Type - then - return Make_Level_Literal (Scope_Depth (Standard_Standard)); - - -- Stand-alone object of an anonymous access type "SAOAAT" - - elsif (Is_Formal (E) - or else Ekind (E) in E_Variable - | E_Constant) - and then Present (Get_Dynamic_Accessibility (E)) - and then (Level = Dynamic_Level - or else Level = Zero_On_Dynamic_Level) - then - if Level = Zero_On_Dynamic_Level then - return Make_Level_Literal - (Scope_Depth (Standard_Standard)); - end if; - - -- No_Dynamic_Accessibility_Checks restriction override for - -- alternative accessibility model. - - if Allow_Alt_Model - and then No_Dynamic_Accessibility_Checks_Enabled (E) - then - -- In the alternative model the level is that of the - -- designated type entity's context. - - if Debug_Flag_Underscore_B then - return Make_Level_Literal (Typ_Access_Level (Etype (E))); - - -- Otherwise the level depends on the entity's context - - elsif Is_Formal (E) then - return Make_Level_Literal - (Subprogram_Access_Level - (Enclosing_Subprogram (E))); - else - return Make_Level_Literal - (Scope_Depth (Enclosing_Dynamic_Scope (E))); - end if; - end if; - - -- Return the dynamic level in the normal case - - return New_Occurrence_Of - (Get_Dynamic_Accessibility (E), Loc); - - -- Initialization procedures have a special extra accessibility - -- parameter associated with the level at which the object - -- being initialized exists - - elsif Ekind (E) = E_Record_Type - and then Is_Limited_Record (E) - and then Current_Scope = Init_Proc (E) - and then Present (Init_Proc_Level_Formal (Current_Scope)) - then - return New_Occurrence_Of - (Init_Proc_Level_Formal (Current_Scope), Loc); - - -- Current instance of the type is deeper than that of the type - -- according to RM 3.10.2 (21). - - elsif Is_Type (E) then - -- When restriction No_Dynamic_Accessibility_Checks is active - -- along with -gnatd_b. - - if Allow_Alt_Model - and then No_Dynamic_Accessibility_Checks_Enabled (E) - and then Debug_Flag_Underscore_B - then - return Make_Level_Literal (Typ_Access_Level (E)); - end if; - - -- Normal path - - return Make_Level_Literal (Typ_Access_Level (E) + 1); - - -- Move up the renamed entity or object if it came from source - -- since expansion may have created a dummy renaming under - -- certain circumstances. - - -- Note: We check if the original node of the renaming comes - -- from source because the node may have been rewritten. - - elsif Present (Renamed_Entity_Or_Object (E)) - and then Comes_From_Source - (Original_Node (Renamed_Entity_Or_Object (E))) - then - return Accessibility_Level (Renamed_Entity_Or_Object (E)); - - -- Named access types get their level from their associated type - - elsif Is_Named_Access_Type (Etype (E)) then - return Make_Level_Literal - (Typ_Access_Level (Etype (E))); - - -- Check if E is an expansion-generated renaming of an iterator - -- by examining Related_Expression. If so, determine the - -- accessibility level based on the original expression. - - elsif Ekind (E) in E_Constant | E_Variable - and then Present (Related_Expression (E)) - then - return Accessibility_Level (Related_Expression (E)); - - elsif Level = Dynamic_Level - and then Ekind (E) in E_In_Parameter | E_In_Out_Parameter - and then Present (Init_Proc_Level_Formal (Scope (E))) - then - return New_Occurrence_Of - (Init_Proc_Level_Formal (Scope (E)), Loc); - - -- Normal object - get the level of the enclosing scope - - else - return Make_Level_Literal - (Scope_Depth (Enclosing_Dynamic_Scope (E))); - end if; - - -- Handle indexed and selected components including the special cases - -- whereby there is an implicit dereference, a component of a - -- composite type, or a function call in prefix notation. - - -- We don't handle function calls in prefix notation correctly ??? - - when N_Indexed_Component | N_Selected_Component | N_Slice => - Pre := Prefix (E); - - -- Fetch the original node when the prefix comes from the result - -- of expanding a function call since we want to find the level - -- of the original source call. - - if not Comes_From_Source (Pre) - and then Nkind (Original_Node (Pre)) = N_Function_Call - then - Pre := Original_Node (Pre); - end if; - - -- When E is an indexed component or selected component and - -- the current Expr is a function call, we know that we are - -- looking at an expanded call in prefix notation. - - if Nkind (Expr) = N_Function_Call then - return Function_Call_Or_Allocator_Level (Expr); - - -- If the prefix is a named access type, then we are dealing - -- with an implicit deferences. In that case the level is that - -- of the named access type in the prefix. - - elsif Is_Named_Access_Type (Etype (Pre)) then - return Make_Level_Literal - (Typ_Access_Level (Etype (Pre))); - - -- The current expression is a named access type, so there is no - -- reason to look at the prefix. Instead obtain the level of E's - -- named access type. - - elsif Is_Named_Access_Type (Etype (E)) then - return Make_Level_Literal - (Typ_Access_Level (Etype (E))); - - -- A nondiscriminant selected component where the component - -- is an anonymous access type means that its associated - -- level is that of the containing type - see RM 3.10.2 (16). - - -- Note that when restriction No_Dynamic_Accessibility_Checks is - -- in effect we treat discriminant components as regular - -- components. - - elsif - (Nkind (E) = N_Selected_Component - and then Ekind (Etype (E)) = E_Anonymous_Access_Type - and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type - and then (not (Nkind (Selector_Name (E)) in N_Has_Entity - and then Ekind (Entity (Selector_Name (E))) - = E_Discriminant) - - -- The alternative accessibility models both treat - -- discriminants as regular components. - - or else (No_Dynamic_Accessibility_Checks_Enabled (E) - and then Allow_Alt_Model))) - - -- Arrays featuring components of anonymous access components - -- get their corresponding level from their containing type's - -- declaration. - - or else - (Nkind (E) = N_Indexed_Component - and then Ekind (Etype (E)) = E_Anonymous_Access_Type - and then Ekind (Etype (Pre)) in Array_Kind - and then Ekind (Component_Type (Base_Type (Etype (Pre)))) - = E_Anonymous_Access_Type) - then - -- When restriction No_Dynamic_Accessibility_Checks is active - -- and -gnatd_b set, the level is that of the designated type. - - if Allow_Alt_Model - and then No_Dynamic_Accessibility_Checks_Enabled (E) - and then Debug_Flag_Underscore_B - then - return Make_Level_Literal - (Typ_Access_Level (Etype (E))); - end if; - - -- Otherwise proceed normally - - return Make_Level_Literal - (Typ_Access_Level (Etype (Prefix (E)))); - - -- The accessibility calculation routine that handles function - -- calls (Function_Call_Level) assumes, in the case the - -- result is of an anonymous access type, that the result will be - -- used "in its entirety" when the call is present within an - -- assignment or object declaration. - - -- To properly handle cases where the result is not used in its - -- entirety, we test if the prefix of the component in question is - -- a function call, which tells us that one of its components has - -- been identified and is being accessed. Therefore we can - -- conclude that the result is not used "in its entirety" - -- according to RM 3.10.2 (10.2/3). - - elsif Nkind (Pre) = N_Function_Call - and then not Is_Named_Access_Type (Etype (Pre)) - then - -- Dynamic checks are generated when we are within a return - -- value or we are in a function call within an anonymous - -- access discriminant constraint of a return object (signified - -- by In_Return_Context) on the side of the callee. - - -- So, in this case, return a library accessibility level to - -- null out the check on the side of the caller. - - if (In_Return_Value (E) - or else In_Return_Context) - and then Level /= Dynamic_Level - then - return Make_Level_Literal - (Scope_Depth (Standard_Standard)); - end if; - - return Make_Level_Literal - (Innermost_Master_Scope_Depth (Expr)); - - -- Otherwise, continue recursing over the expression prefixes - - else - return Accessibility_Level (Prefix (E)); - end if; - - -- Qualified expressions - - when N_Qualified_Expression => - if Is_Named_Access_Type (Etype (E)) then - return Make_Level_Literal - (Typ_Access_Level (Etype (E))); - else - return Accessibility_Level (Expression (E)); - end if; - - -- Handle function calls - - when N_Function_Call => - return Function_Call_Or_Allocator_Level (E); - - -- Explicit dereference accessibility level calculation - - when N_Explicit_Dereference => - Pre := Original_Node (Prefix (E)); - - -- The prefix is a named access type so the level is taken from - -- its type. - - if Is_Named_Access_Type (Etype (Pre)) then - return Make_Level_Literal (Typ_Access_Level (Etype (Pre))); - - -- Otherwise, recurse deeper - - else - return Accessibility_Level (Prefix (E)); - end if; - - -- Type conversions - - when N_Type_Conversion | N_Unchecked_Type_Conversion => - -- View conversions are special in that they require use to - -- inspect the expression of the type conversion. - - -- Allocators of anonymous access types are internally generated, - -- so recurse deeper in that case as well. - - if Is_View_Conversion (E) - or else Ekind (Etype (E)) = E_Anonymous_Access_Type - then - return Accessibility_Level (Expression (E)); - - -- We don't care about the master if we are looking at a named - -- access type. - - elsif Is_Named_Access_Type (Etype (E)) then - return Make_Level_Literal - (Typ_Access_Level (Etype (E))); - - -- In section RM 3.10.2 (10/4) the accessibility rules for - -- aggregates and value conversions are outlined. Are these - -- followed in the case of initialization of an object ??? - - -- Should use Innermost_Master_Scope_Depth ??? - - else - return Accessibility_Level (Current_Scope); - end if; - - -- Default to the type accessibility level for the type of the - -- expression's entity. - - when others => - return Make_Level_Literal (Typ_Access_Level (Etype (E))); - end case; - end Accessibility_Level; - - -------------------------------- - -- Static_Accessibility_Level -- - -------------------------------- - - function Static_Accessibility_Level - (Expr : Node_Id; - Level : Static_Accessibility_Level_Kind; - In_Return_Context : Boolean := False) return Uint - is - begin - return Intval - (Accessibility_Level (Expr, Level, In_Return_Context)); - end Static_Accessibility_Level; - ---------------------------------- -- Acquire_Warning_Match_String -- ---------------------------------- @@ -7431,47 +6697,6 @@ package body Sem_Util is return Is_Class_Wide_Type (Typ) or else Needs_Finalization (Typ); end CW_Or_Needs_Finalization; - ------------------------------- - -- Deepest_Type_Access_Level -- - ------------------------------- - - function Deepest_Type_Access_Level - (Typ : Entity_Id; - Allow_Alt_Model : Boolean := True) return Uint - is - begin - if Ekind (Typ) = E_Anonymous_Access_Type - and then not Is_Local_Anonymous_Access (Typ) - and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration - then - -- No_Dynamic_Accessibility_Checks override for alternative - -- accessibility model. - - if Allow_Alt_Model - and then No_Dynamic_Accessibility_Checks_Enabled (Typ) - then - return Type_Access_Level (Typ, Allow_Alt_Model); - end if; - - -- Typ is the type of an Ada 2012 stand-alone object of an anonymous - -- access type. - - return - Scope_Depth (Enclosing_Dynamic_Scope - (Defining_Identifier - (Associated_Node_For_Itype (Typ)))); - - -- For generic formal type, return Int'Last (infinite). - -- See comment preceding Is_Generic_Type call in Type_Access_Level. - - 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; - --------------------- -- Defining_Entity -- --------------------- @@ -8182,21 +7407,6 @@ package body Sem_Util is return False; end Discriminated_Size; - ----------------------------------- - -- Effective_Extra_Accessibility -- - ----------------------------------- - - function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is - begin - if Present (Renamed_Object (Id)) - and then Is_Entity_Name (Renamed_Object (Id)) - then - return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); - else - return Extra_Accessibility (Id); - end if; - end Effective_Extra_Accessibility; - ----------------------------- -- Effective_Reads_Enabled -- ----------------------------- @@ -10776,30 +9986,6 @@ package body Sem_Util is end if; end Gather_Components; - ------------------------------- - -- Get_Dynamic_Accessibility -- - ------------------------------- - - function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id is - begin - -- When minimum accessibility is set for E then we utilize it - except - -- in a few edge cases like the expansion of select statements where - -- generated subprogram may attempt to unnecessarily use a minimum - -- accessibility object declared outside of scope. - - -- To avoid these situations where expansion may get complex we verify - -- that the minimum accessibility object is within scope. - - if Is_Formal (E) - and then Present (Minimum_Accessibility (E)) - and then In_Open_Scopes (Scope (Minimum_Accessibility (E))) - then - return Minimum_Accessibility (E); - end if; - - return Extra_Accessibility (E); - end Get_Dynamic_Accessibility; - ------------------------ -- Get_Actual_Subtype -- ------------------------ @@ -12006,85 +11192,6 @@ package body Sem_Util is end if; end Get_Views; - ----------------------- - -- Has_Access_Values -- - ----------------------- - - function Has_Access_Values (T : Entity_Id) return Boolean - is - Typ : constant Entity_Id := Underlying_Type (T); - - begin - -- Case of a private type which is not completed yet. This can only - -- happen in the case of a generic formal type appearing directly, or - -- as a component of the type to which this function is being applied - -- at the top level. Return False in this case, since we certainly do - -- not know that the type contains access types. - - if No (Typ) then - return False; - - elsif Is_Access_Type (Typ) then - return True; - - elsif Is_Array_Type (Typ) then - return Has_Access_Values (Component_Type (Typ)); - - elsif Is_Record_Type (Typ) then - declare - Comp : Entity_Id; - - begin - -- Loop to check components - - Comp := First_Component_Or_Discriminant (Typ); - while Present (Comp) loop - - -- Check for access component, tag field does not count, even - -- though it is implemented internally using an access type. - - if Has_Access_Values (Etype (Comp)) - and then Chars (Comp) /= Name_uTag - then - return True; - end if; - - Next_Component_Or_Discriminant (Comp); - end loop; - end; - - return False; - - else - return False; - end if; - end Has_Access_Values; - - --------------------------------------- - -- Has_Anonymous_Access_Discriminant -- - --------------------------------------- - - function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean - is - Disc : Node_Id; - - begin - if not Has_Discriminants (Typ) then - return False; - end if; - - Disc := First_Discriminant (Typ); - while Present (Disc) loop - if Ekind (Etype (Disc)) = E_Anonymous_Access_Type then - return True; - end if; - - Next_Discriminant (Disc); - end loop; - - return False; - end Has_Anonymous_Access_Discriminant; - ------------------------------ -- Has_Compatible_Alignment -- ------------------------------ @@ -14382,32 +13489,6 @@ package body Sem_Util is end if; end Has_Tagged_Component; - -------------------------------------------- - -- Has_Unconstrained_Access_Discriminants -- - -------------------------------------------- - - function Has_Unconstrained_Access_Discriminants - (Subtyp : Entity_Id) return Boolean - is - Discr : Entity_Id; - - begin - if Has_Discriminants (Subtyp) - and then not Is_Constrained (Subtyp) - then - Discr := First_Discriminant (Subtyp); - while Present (Discr) loop - if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then - return True; - end if; - - Next_Discriminant (Discr); - end loop; - end if; - - return False; - end Has_Unconstrained_Access_Discriminants; - ----------------------------- -- Has_Undefined_Reference -- ----------------------------- @@ -15989,28 +15070,6 @@ package body Sem_Util is end if; end Invalid_Scalar_Value; - -------------------------------- - -- Is_Anonymous_Access_Actual -- - -------------------------------- - - function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean is - Par : Node_Id; - begin - if Ekind (Etype (N)) /= E_Anonymous_Access_Type then - return False; - end if; - - Par := Parent (N); - while Present (Par) - and then Nkind (Par) in N_Case_Expression - | N_If_Expression - | N_Parameter_Association - loop - Par := Parent (Par); - end loop; - return Nkind (Par) in N_Subprogram_Call; - end Is_Anonymous_Access_Actual; - ------------------------ -- Is_Access_Variable -- ------------------------ @@ -21224,38 +20283,6 @@ package body Sem_Util is and then Is_Single_Concurrent_Type (Etype (Id)); end Is_Single_Task_Object; - -------------------------------------- - -- Is_Special_Aliased_Formal_Access -- - -------------------------------------- - - function Is_Special_Aliased_Formal_Access - (Exp : Node_Id; - In_Return_Context : Boolean := False) return Boolean - is - Scop : constant Entity_Id := Current_Subprogram; - begin - -- Verify the expression is an access reference to 'Access within a - -- return statement as this is the only time an explicitly aliased - -- formal has different semantics. - - if Nkind (Exp) /= N_Attribute_Reference - or else Get_Attribute_Id (Attribute_Name (Exp)) /= Attribute_Access - or else not (In_Return_Value (Exp) - or else In_Return_Context) - or else not Needs_Result_Accessibility_Level (Scop) - then - return False; - end if; - - -- Check if the prefix of the reference is indeed an explicitly aliased - -- formal parameter for the function Scop. Additionally, we must check - -- that Scop returns an anonymous access type, otherwise the special - -- rules dictating a need for a dynamic check are not in effect. - - return Is_Entity_Name (Prefix (Exp)) - and then Is_Explicitly_Aliased (Entity (Prefix (Exp))); - end Is_Special_Aliased_Formal_Access; - ----------------------------- -- Is_Specific_Tagged_Type -- ----------------------------- @@ -23228,144 +22255,6 @@ package body Sem_Util is end if; end Needs_One_Actual; - -------------------------------------- - -- Needs_Result_Accessibility_Level -- - -------------------------------------- - - function Needs_Result_Accessibility_Level - (Func_Id : Entity_Id) return Boolean - is - Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); - - function Has_Unconstrained_Access_Discriminant_Component - (Comp_Typ : Entity_Id) return Boolean; - -- Returns True if any component of the type has an unconstrained access - -- discriminant. - - ----------------------------------------------------- - -- Has_Unconstrained_Access_Discriminant_Component -- - ----------------------------------------------------- - - function Has_Unconstrained_Access_Discriminant_Component - (Comp_Typ : Entity_Id) return Boolean - is - begin - if not Is_Limited_Type (Comp_Typ) then - return False; - - -- Only limited types can have access discriminants with - -- defaults. - - elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then - return True; - - elsif Is_Array_Type (Comp_Typ) then - return Has_Unconstrained_Access_Discriminant_Component - (Underlying_Type (Component_Type (Comp_Typ))); - - elsif Is_Record_Type (Comp_Typ) then - declare - Comp : Entity_Id; - - begin - Comp := First_Component (Comp_Typ); - while Present (Comp) loop - if Has_Unconstrained_Access_Discriminant_Component - (Underlying_Type (Etype (Comp))) - then - return True; - end if; - - Next_Component (Comp); - end loop; - end; - end if; - - return False; - end Has_Unconstrained_Access_Discriminant_Component; - - Disable_Tagged_Cases : constant Boolean := True; - -- Flag used to temporarily disable a "True" result for tagged types. - -- See comments further below for details. - - -- Start of processing for Needs_Result_Accessibility_Level - - begin - -- False if completion unavailable, which can happen when we are - -- analyzing an abstract subprogram or if the subprogram has - -- delayed freezing. - - if No (Func_Typ) then - return False; - - -- False if not a function, also handle enum-lit renames case - - elsif Func_Typ = Standard_Void_Type - or else Is_Scalar_Type (Func_Typ) - then - return False; - - -- Handle a corner case, a cross-dialect subp renaming. For example, - -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when - -- an Ada 2005 (or earlier) unit references predefined run-time units. - - elsif Present (Alias (Func_Id)) then - - -- Unimplemented: a cross-dialect subp renaming which does not set - -- the Alias attribute (e.g., a rename of a dereference of an access - -- to subprogram value). ??? - - return Present (Extra_Accessibility_Of_Result (Alias (Func_Id))); - - -- Remaining cases require Ada 2012 mode, unless they are dispatching - -- operations, since they may be overridden by Ada_2012 primitives. - - elsif Ada_Version < Ada_2012 - and then not Is_Dispatching_Operation (Func_Id) - then - return False; - - -- Handle the situation where a result is an anonymous access type - -- RM 3.10.2 (10.3/3). - - elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then - return True; - - -- In the case of, say, a null tagged record result type, the need for - -- this extra parameter might not be obvious so this function returns - -- True for all tagged types for compatibility reasons. - - -- A function with, say, a tagged null controlling result type might - -- be overridden by a primitive of an extension having an access - -- discriminant and the overrider and overridden must have compatible - -- calling conventions (including implicitly declared parameters). - - -- Similarly, values of one access-to-subprogram type might designate - -- both a primitive subprogram of a given type and a function which is, - -- for example, not a primitive subprogram of any type. Again, this - -- requires calling convention compatibility. It might be possible to - -- solve these issues by introducing wrappers, but that is not the - -- approach that was chosen. - - -- Note: Despite the reasoning noted above, the extra accessibility - -- parameter for tagged types is disabled for performance reasons. - - elsif Is_Tagged_Type (Func_Typ) then - return not Disable_Tagged_Cases; - - elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then - return True; - - elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then - return True; - - -- False for all other cases - - else - return False; - end if; - end Needs_Result_Accessibility_Level; - ---------------------------- -- Needs_Secondary_Stack -- ---------------------------- @@ -29179,19 +28068,6 @@ package body Sem_Util is and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); end Subject_To_Loop_Entry_Attributes; - ----------------------------- - -- Subprogram_Access_Level -- - ----------------------------- - - function Subprogram_Access_Level (Subp : Entity_Id) return Uint is - begin - if Present (Alias (Subp)) then - return Subprogram_Access_Level (Alias (Subp)); - else - return Scope_Depth (Enclosing_Dynamic_Scope (Subp)); - end if; - end Subprogram_Access_Level; - --------------------- -- Subprogram_Name -- --------------------- @@ -29651,179 +28527,6 @@ package body Sem_Util is Discard := Traverse (Node); end Traverse_More_Proc; - ----------------------- - -- Type_Access_Level -- - ----------------------- - - function Type_Access_Level - (Typ : Entity_Id; - Allow_Alt_Model : Boolean := True; - Assoc_Ent : Entity_Id := Empty) return Uint - is - Btyp : Entity_Id := Base_Type (Typ); - Def_Ent : Entity_Id; - - begin - -- Ada 2005 (AI-230): For most cases of anonymous access types, we - -- simply use the level where the type is declared. This is true for - -- stand-alone object declarations, and for anonymous access types - -- associated with components the level is the same as that of the - -- enclosing composite type. However, special treatment is needed for - -- the cases of access parameters, return objects of an anonymous access - -- type, and, in Ada 95, access discriminants of limited types. - - if Is_Access_Type (Btyp) then - if Ekind (Btyp) = E_Anonymous_Access_Type then - -- No_Dynamic_Accessibility_Checks restriction override for - -- alternative accessibility model. - - if Allow_Alt_Model - and then No_Dynamic_Accessibility_Checks_Enabled (Btyp) - then - -- In the -gnatd_b model, the level of an anonymous access - -- type is always that of the designated type. - - if Debug_Flag_Underscore_B then - return Type_Access_Level - (Designated_Type (Btyp), Allow_Alt_Model); - end if; - - -- When an anonymous access type's Assoc_Ent is specified, - -- calculate the result based on the general accessibility - -- level routine. - - -- We would like to use Associated_Node_For_Itype here instead, - -- but in some cases it is not fine grained enough ??? - - if Present (Assoc_Ent) then - return Static_Accessibility_Level - (Assoc_Ent, Object_Decl_Level); - end if; - - -- Otherwise take the context of the anonymous access type into - -- account. - - -- Obtain the defining entity for the internally generated - -- anonymous access type. - - Def_Ent := Defining_Entity_Or_Empty - (Associated_Node_For_Itype (Typ)); - - if Present (Def_Ent) then - -- When the defining entity is a subprogram then we know the - -- anonymous access type Typ has been generated to either - -- describe an anonymous access type formal or an anonymous - -- access result type. - - -- Since we are only interested in the formal case, avoid - -- the anonymous access result type. - - if Is_Subprogram (Def_Ent) - and then not (Ekind (Def_Ent) = E_Function - and then Etype (Def_Ent) = Typ) - then - -- When the type comes from an anonymous access - -- parameter, the level is that of the subprogram - -- declaration. - - return Scope_Depth (Def_Ent); - - -- When the type is an access discriminant, the level is - -- that of the type. - - elsif Ekind (Def_Ent) = E_Discriminant then - return Scope_Depth (Scope (Def_Ent)); - end if; - end if; - - -- If the type is a nonlocal anonymous access type (such as for - -- an access parameter) we treat it as being declared at the - -- library level to ensure that names such as X.all'access don't - -- fail static accessibility checks. - - elsif not Is_Local_Anonymous_Access (Typ) then - return Scope_Depth (Standard_Standard); - - -- If this is a return object, the accessibility level is that of - -- the result subtype of the enclosing function. The test here is - -- little complicated, because we have to account for extended - -- return statements that have been rewritten as blocks, in which - -- case we have to find and the Is_Return_Object attribute of the - -- itype's associated object. It would be nice to find a way to - -- simplify this test, but it doesn't seem worthwhile to add a new - -- flag just for purposes of this test. ??? - - elsif Ekind (Scope (Btyp)) = E_Return_Statement - or else - (Is_Itype (Btyp) - and then Nkind (Associated_Node_For_Itype (Btyp)) = - N_Object_Declaration - and then Is_Return_Object - (Defining_Identifier - (Associated_Node_For_Itype (Btyp)))) - then - declare - Scop : Entity_Id; - - begin - Scop := Scope (Scope (Btyp)); - while Present (Scop) loop - exit when Ekind (Scop) = E_Function; - Scop := Scope (Scop); - end loop; - - -- Treat the return object's type as having the level of the - -- function's result subtype (as per RM05-6.5(5.3/2)). - - return Type_Access_Level (Etype (Scop), Allow_Alt_Model); - end; - end if; - end if; - - Btyp := Root_Type (Btyp); - - -- The accessibility level of anonymous access types associated with - -- discriminants is that of the current instance of the type, and - -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). - - -- AI-402: access discriminants have accessibility based on the - -- object rather than the type in Ada 2005, so the above paragraph - -- doesn't apply. - - -- ??? Needs completion with rules from AI-416 - - if Ada_Version <= Ada_95 - and then Ekind (Typ) = E_Anonymous_Access_Type - and then Present (Associated_Node_For_Itype (Typ)) - and then Nkind (Associated_Node_For_Itype (Typ)) = - N_Discriminant_Specification - then - return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; - end if; - end if; - - -- Return library level for a generic formal type. This is done because - -- RM(10.3.2) says that "The statically deeper relationship does not - -- apply to ... a descendant of a generic formal type". Rather than - -- checking at each point where a static accessibility check is - -- performed to see if we are dealing with a formal type, this rule is - -- implemented by having Type_Access_Level and Deepest_Type_Access_Level - -- return extreme values for a formal type; Deepest_Type_Access_Level - -- returns Int'Last. By calling the appropriate function from among the - -- two, we ensure that the static accessibility check will pass if we - -- happen to run into a formal type. More specifically, we should call - -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the - -- call occurs as part of a static accessibility check and the error - -- case is the case where the type's level is too shallow (as opposed - -- to too deep). - - if Is_Generic_Type (Root_Type (Btyp)) then - return Scope_Depth (Standard_Standard); - end if; - - return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); - end Type_Access_Level; - ------------------------------------ -- Type_Without_Stream_Operation -- ------------------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e651b20..34aaa9a 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -44,40 +44,6 @@ package Sem_Util is -- including the cases where there can't be any because e.g. the type is -- not tagged. - type Accessibility_Level_Kind is - (Dynamic_Level, - Object_Decl_Level, - Zero_On_Dynamic_Level); - -- Accessibility_Level_Kind is an enumerated type which captures the - -- different modes in which an accessibility level could be obtained for - -- a given expression. - - -- When in the context of the function Accessibility_Level, - -- Accessibility_Level_Kind signals what type of accessibility level to - -- obtain. For example, when Level is Dynamic_Level, a defining identifier - -- associated with a SAOOAAT may be returned or an N_Integer_Literal node. - -- When the level is Object_Decl_Level, an N_Integer_Literal node is - -- returned containing the level of the declaration of the object if - -- relevant (be it a SAOOAAT or otherwise). Finally, Zero_On_Dynamic_Level - -- returns library level for all cases where the accessibility level is - -- dynamic (used to bypass static accessibility checks in dynamic cases). - - function Accessibility_Level - (Expr : Node_Id; - Level : Accessibility_Level_Kind; - In_Return_Context : Boolean := False; - Allow_Alt_Model : Boolean := True) return Node_Id; - -- Centralized accessibility level calculation routine for finding the - -- accessibility level of a given expression Expr. - - -- In_Return_Context forces the Accessibility_Level calculations to be - -- carried out "as if" Expr existed in a return value. This is useful for - -- calculating the accessibility levels for discriminant associations - -- and return aggregates. - - -- The Allow_Alt_Model parameter allows the alternative level calculation - -- under the restriction No_Dynamic_Accessibility_Checks to be performed. - function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String; -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to get -- the given string argument, adding leading and trailing asterisks if they @@ -696,22 +662,6 @@ package Sem_Util is -- as Needs_Finalization except with pragma Restrictions (No_Finalization), -- in which case we know that class-wide objects do not need finalization. - function Deepest_Type_Access_Level - (Typ : Entity_Id; - Allow_Alt_Model : Boolean := True) return Uint; - - -- Same as Type_Access_Level, except that if the type is the type of an Ada - -- 2012 stand-alone object of an anonymous access type, then return the - -- static accessibility level of the object. In that case, the dynamic - -- accessibility level of the object may take on values in a range. The low - -- bound of that range is returned by Type_Access_Level; this function - -- yields the high bound of that range. Also differs from Type_Access_Level - -- in the case of a descendant of a generic formal type (returns Int'Last - -- instead of 0). - - -- The Allow_Alt_Model parameter allows the alternative level calculation - -- under the restriction No_Dynamic_Accessibility_Checks to be performed. - function Defining_Entity (N : Node_Id) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- declaration has a specification, the entity is obtained from the @@ -786,10 +736,6 @@ package Sem_Util is -- private components of protected objects, but is generally useful when -- restriction No_Implicit_Heap_Allocation is active. - function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id; - -- Same as Einfo.Extra_Accessibility except thtat object renames - -- are looked through. - function Effective_Reads_Enabled (Id : Entity_Id) return Boolean; -- Id should be the entity of a state abstraction, an object, or a type. -- Returns True iff Id is subject to external property Effective_Reads. @@ -1146,10 +1092,6 @@ package Sem_Util is -- discriminants. Otherwise all components of the parent must be included -- in the subtype for semantic analysis. - function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id; - -- Obtain the accessibility level for a given entity formal taking into - -- account both extra and minimum accessibility. - function Get_Actual_Subtype (N : Node_Id) return Entity_Id; -- Given a node for an expression, obtain the actual subtype of the -- expression. In the case of a parameter where the formal is an @@ -1393,18 +1335,6 @@ package Sem_Util is -- don't look inside packed array types. If Recurse is False, just -- go down one level (so it's no longer the "fullest" view). - function Has_Access_Values (T : Entity_Id) return Boolean; - -- Returns true if the underlying type of T is an access type, or has a - -- component (at any recursive level) that is an access type. This is a - -- conservative predicate, if it is not known whether or not T contains - -- access values (happens for generic formals in some cases), then False is - -- returned. Note that tagged types return False. Even though the tag is - -- implemented as an access type internally, this function tests only for - -- access types known to the programmer. See also Has_Tagged_Component. - - function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean; - -- Returns True if Typ has one or more anonymous access discriminants - type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); -- Result of Has_Compatible_Alignment test, description found below. Note -- that the values are arranged in increasing order of problematicness. @@ -1544,20 +1474,6 @@ package Sem_Util is -- Return True if the loop has no side effect and can therefore be -- marked for removal. Return False if N is not a N_Loop_Statement. - subtype Static_Accessibility_Level_Kind - is Accessibility_Level_Kind range Object_Decl_Level - .. Zero_On_Dynamic_Level; - -- Restrict the reange of Accessibility_Level_Kind to be non-dynamic for - -- use in the static version of Accessibility_Level below. - - function Static_Accessibility_Level - (Expr : Node_Id; - Level : Static_Accessibility_Level_Kind; - In_Return_Context : Boolean := False) return Uint; - -- Overloaded version of Accessibility_Level which returns a universal - -- integer for use in compile-time checking. Note: Level is restricted to - -- be non-dynamic. - function Is_Newly_Constructed (Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean; -- Indicates whether a given expression is "newly constructed" (RM 4.4). @@ -1644,11 +1560,6 @@ package Sem_Util is -- a tagged type or has a subcomponent that is tagged. Returns False for a -- noncomposite type, or if no tagged subcomponents are present. - function Has_Unconstrained_Access_Discriminants - (Subtyp : Entity_Id) return Boolean; - -- Returns True if the given subtype is unconstrained and has one or more - -- access discriminants. - function Has_Undefined_Reference (Expr : Node_Id) return Boolean; -- Given arbitrary expression Expr, determine whether it contains at -- least one name whose entity is Any_Id. @@ -1822,10 +1733,6 @@ package Sem_Util is -- pragma Initialize_Scalars or by the binder. Return an expression created -- at source location Loc, which denotes the invalid value. - function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean; - -- Determine if N is used as an actual for a call whose corresponding - -- formal is of an anonymous access type. - function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean; -- True if E is the constructed wrapper for an access_to_subprogram -- type with Pre/Postconditions. @@ -2400,21 +2307,6 @@ package Sem_Util is -- Determine whether arbitrary entity Id denotes the anonymous object -- created for a single task type. - function Is_Special_Aliased_Formal_Access - (Exp : Node_Id; - In_Return_Context : Boolean := False) return Boolean; - -- Determines whether a dynamic check must be generated for explicitly - -- aliased formals within a function Scop for the expression Exp. - - -- In_Return_Context forces Is_Special_Aliased_Formal_Access to assume - -- that Exp is within a return value which is useful for checking - -- expressions within discriminant associations of return objects. - - -- More specially, Is_Special_Aliased_Formal_Access checks that Exp is a - -- 'Access attribute reference within a return statement where the ultimate - -- prefix is an aliased formal of Scop and that Scop returns an anonymous - -- access type. See RM 3.10.2 for more details. - function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean; -- Determine whether an arbitrary [private] type is specifically tagged @@ -2692,12 +2584,6 @@ package Sem_Util is -- syntactic ambiguity that results from an indexing of a function call -- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y). - function Needs_Result_Accessibility_Level - (Func_Id : Entity_Id) return Boolean; - -- Ada 2012 (AI05-0234): Return True if the function needs an implicit - -- parameter to identify the accessibility level of the function result - -- "determined by the point of call". - function Needs_Secondary_Stack (Id : Entity_Id) return Boolean; -- Return true if functions whose result type is Id must return on the -- secondary stack, i.e. allocate the return object on this stack. @@ -3340,9 +3226,6 @@ package Sem_Util is -- Determine whether node N is a loop statement subject to at least one -- 'Loop_Entry attribute. - function Subprogram_Access_Level (Subp : Entity_Id) return Uint; - -- Return the accessibility level of the view denoted by Subp - function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean; -- Return True if Typ supports the GCC built-in atomic operations (i.e. if -- Typ is properly sized and aligned). @@ -3373,19 +3256,6 @@ package Sem_Util is -- returned, i.e. Traverse_More_Func is called and the result is simply -- discarded. - function Type_Access_Level - (Typ : Entity_Id; - Allow_Alt_Model : Boolean := True; - Assoc_Ent : Entity_Id := Empty) return Uint; - -- Return the accessibility level of Typ - - -- The Allow_Alt_Model parameter allows the alternative level calculation - -- under the restriction No_Dynamic_Accessibility_Checks to be performed. - - -- Assoc_Ent allows for the optional specification of the entity associated - -- with Typ. This gets utilized mostly for anonymous access type - -- processing, where context matters in interpreting Typ's level. - function Type_Without_Stream_Operation (T : Entity_Id; Op : TSS_Name_Type := TSS_Null) return Entity_Id; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index cbfabd2..1311916 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Accessibility; use Accessibility; with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index c41b0f2..7accb01 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -953,6 +953,11 @@ package Sinfo is -- Present in N_Simple_Return_Statement nodes. True if this node was -- constructed as part of the N_Extended_Return_Statement expansion. + -- Comes_From_Iterator + -- Present in N_Object_Renaming_Declaration nodes. True if this node was + -- was constructed as part of the expansion of an iterator + -- specification. + -- Compile_Time_Known_Aggregate -- Present in N_Aggregate nodes. Set for aggregates which can be fully -- evaluated at compile time without raising constraint error. Such |